Udvælge data ud fra variabel og kopiere til andet ark

Prøv at kikke på avanseret filter, den kan gøre det

Jeg kan sagtens udføre det jeg vil manuelt via filter. Men regnearket skal bruges af andre, og derfor vil jeg gerne automatisere det.

Forslag:


Rem Koden anbringes i Module - evt. forbindes med "en knap"
Rem projektArk hedder Projekt xxxx
Dim detteArk, detteProjekt, denLedigeRæk
Sub opdaterFraData()
Rem hent data om projekt-ark

    denLedigeRæk = førsteLedigerække        'første ledige række i projekt - ellers sæt den til 1
    detteArk = ActiveSheet.Name
    detteProjekt = Mid(ActiveSheet.Name, 9)
   
Rem Hent data fra data-ark
    findData Val(detteProjekt)
End Sub
Private Sub findData(pnr)
    ActiveWorkbook.Sheets("data").Activate
    antalræk = ActiveCell.SpecialCells(xlLastCell).Row
    For r = 1 To antalræk
        If Cells(r, 4) = pnr Then
            Range("A" + CStr(r) + ":P" + CStr(r)).Select
            Selection.Copy
            ActiveWorkbook.Sheets(detteArk).Select
            Cells(denLedigeRæk, 1).Select
            ActiveSheet.Paste
            Cells(denLedigeRæk, 4).Select
            Exit Sub
        End If
    Next r
End Sub
Private Function førsteLedigerække()
    For r = 1 To 65000
        If Cells(r, 4) = "" Then
            førsteLedigerække = r
            Exit Function
        End If
    Next r
End Function

Koden sletter det der står i forvejen.
Om du kalder det ark som der skal data over på, for "Projekt 1001" eller kun "1001", er lige meget, koden tager  det der står efter det sidste mellemrum i navnet, ellers kun navnet.

Public Sub OverførData()
    Dim Data As Variant, I As Long, R As Long, T As Integer, Søg As Integer, A As Variant
    Data = ActiveWorkbook.Sheets("data").UsedRange
        A = Split(ActiveSheet.Name, " ")
        Søg = A(UBound(A))
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    For T = 1 To UBound(Data, 2)
        Cells(1, T) = Data(1, T)    ' overskrifter, fra data arket,
        ' jeg går ud fra at de står i første række
    Next
    R = 2    ' starter i række 2
    For I = 2 To UBound(Data)
        If Data(I, 4) = Søg Then
            For T = 1 To UBound(Data, 2)
                Cells(R, T) = Data(I, T)
            Next
            R = R + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Hej Kabbak

Jeg har prøvet det første forslag du har givet og har rettet det lidt til, så det nu ser således ud:
Sub opdaterFraData()

Dim denledigeRæk As Integer
Dim detteArk As String
Dim detteProjekt As String
Dim pronr As Integer

    denledigeRæk = 6
    detteArk = ActiveSheet.Name
    detteProjekt = Mid(ActiveSheet.Name, 9)
    pronr = ActiveSheet.Range("c1")


    ActiveWorkbook.Sheets("Timeregistrering").Activate
    antalræk = ActiveCell.SpecialCells(xlLastCell).Row 'finder antallet af rækker i arket
   
    For R = 1 To antalræk
        If Cells(R, 4) = pronr Then
            Range("A" + CStr(R) + ":P" + CStr(R)).Select
            Selection.Copy
            ActiveWorkbook.Sheets(detteArk).Select
            Cells(denledigeRæk, 1).Select
            ActiveSheet.Paste
            denledigeRæk = denledigeRæk + 1
        End If
    Next R


End Sub

Men .... det er som om den kun finder den første linie i arket "Timeregistrering" og så stopper der. Er det "next" funktionen jeg har lavet ged i?

prøv:

Sub opdaterFraData()

    Dim denledigeRæk As Integer
    Dim detteArk As String
    Dim detteProjekt As String
    Dim pronr As Integer

    denledigeRæk = 6
    detteArk = ActiveSheet.Name
    detteProjekt = Mid(ActiveSheet.Name, 9)
    pronr = ActiveSheet.Range("c1")


    ActiveWorkbook.Sheets("Timeregistrering").Activate
    antalræk = ActiveCell.SpecialCells(xlLastCell).Row    'finder antallet af rækker i arket

    For R = 1 To antalræk
        If Cells(R, 4) = pronr Then
            Range("A" + CStr(R) + ":P" + CStr(R)).Copy ActiveWorkbook.Sheets(detteArk).Cells(denledigeRæk, 1)
            denledigeRæk = denledigeRæk + 1
        End If
    Next R


End Sub

Det er bare fuldstændig super.
Tak for hjælpen.
Send et svar - så får du point.

et svar ;-))