Kopieren Sie Zeilen basierend auf dem Zellenwert und fügen Sie sie auf einem neuen Blatt mit demselben Zellenwertnamen ein

Ich habe diese VBA erstellt, um Daten von einem Blatt (Quelle) auf ein anderes Blatt (Ziel) zu kopieren, basierend auf den im dritten Blatt (Bedingung) angegebenen Bedingungsdaten:

Sub CopyYes()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Condition As Worksheet


    Set Source = ActiveWorkbook.Worksheets("source")
    Set Target = ActiveWorkbook.Worksheets("target")
    Set Condition = ActiveWorkbook.Worksheets("condition")

    j = 1    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A1:A86")
        For Each c In Source.Range("B2:B1893")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
End Sub

Sie haben eine ziemlich gute Frage zusammengestellt. Es enthält eine klare Beschreibung des Ausgangspunkts und des Ziels. Der Code, den Sie haben, ist ein guter Anfang für die Antwort. Ich habe jedoch nicht versucht, eine Reihe von Reihen so zu gruppieren, wie Sie es wollten, weil ich keine Ahnung hatte, wie das geht. Was ich tat, war, den DATA-Bereich zu durchlaufen und dann mit jeder Reihe nacheinander zu arbeiten. Wenn das Zielarbeitsblatt vorhanden war, habe ich die Zeile hinter der letzten Zeile eingefügt. Wenn das Zielblatt nicht vorhanden war, habe ich das neue Blatt so erstellt, wie Sie es getan haben. Schritt für Schritt mit dem Debugger und Sie werden sehen, wie es funktioniert.

Sub CopyRows()

Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim SheetName As String



With Worksheets("DATA")
Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

    For Each rngCell In rngMyRange

        rngCell.EntireRow.Select

        Selection.Copy

        If (WorksheetExists(rngCell.Value)) Then
            SheetName = rngCell.Value
            Sheets(SheetName).Select
            Set sht = ThisWorkbook.Worksheets(SheetName)
            LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).row
            Rows(LastRow + 1).Select
            Selection.Insert Shift:=xlDown
        Else
            Sheets.Add After:=ActiveSheet
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            ActiveSheet.Name = rngCell.Value
        End If


        'Go back to the DATA sheet
        Sheets("DATA").Select
    Next

End With

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Aber Eileen, Wenn Sie Zellenwerte von COLUMN E anstelle von COLUMN A kopieren und in ein neues Blatt einfügen müssen, werden in Ihrem Ref-Code immer noch Werte aus COLUMN A aufgeführt ......! Wir müssen also vcol = 5 in Zeile 9 ändern

Vielen Dank für all Ihre Antworten. Ich habe tatsächlich einen ziemlich guten Code gefunden, der genau das macht, was ich wollte, ich habe jedoch vergessen, die Referenzseite aufzuschreiben. Hier ist der Code, wenn jemand interessiert ist:

    Sub parse_data()

    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("DATA")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:J1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub

sie können RemoveDuplicates () und Autofilter () - Methoden des Range-Objekts folgendermaßen verwenden:

Option Explicit

Sub CopyRows()
    Dim rngCell As Range
    Dim depSheet As Worksheet

    With Worksheets("DATA") '<--|refer to data sheet
        .Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted
        .Cells(1, 1).value = "Department" '<--| place a dummy header in the temporary header row
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(, .UsedRange.Columns.Count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row
            .value = .Offset(, -.Parent.UsedRange.Columns.Count).value '<--| duplicate departments (column "A") values in helper one
            .RemoveDuplicates Columns:=Array(1), header:=xlYes '<--| leave only departments unique values in "helper" column
            For Each rngCell In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values
                Set depSheet = GetSheet(.Parent.Parent, rngCell.value) '<--|get or add the worksheet corresponding to current department
                With .Offset(, -.Parent.UsedRange.Columns.Count + 1) '<--|refer to departments column
                    .AutoFilter field:=1, Criteria1:=rngCell.value '<--| filter it on current department value
                    With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells
                        depSheet.Cells(depSheet.Rows.Count, 1).End(xlUp).Offset(1).Resize(.Cells.Count, 3).value = .Resize(, 3).value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet
                    End With
                End With
            Next rngCell
            .ClearContents '<--| clear "helper" column
        End With
        .AutoFilterMode = False
        .Rows(1).Delete '<--| delete temporary header row
    End With
 End Sub

Function GetSheet(wb As Workbook, shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name
    On Error GoTo 0
    If GetSheet Is Nothing Then '<--| if there weas no such sheet...
        Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet
        With GetSheet
            .Name = shtName '<--|rename it after passed name
            .Range("A1:C1").value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers
        End With
    End If
End Function