erstellt Blätter basierend auf einer Liste und füllt nur mit Daten, bei denen eine Spalte mit dem Blattnamen übereinstimmt

Question

Ich habe daran gearbeitet, eine Arbeitsmappe erstellen zu lassen und diese Blätter basierend auf Werten in einer Pivot-Tabelle zu füllen. Durch meine verschiedene Durchsuchung, habe ich in der Lage gewesen Blätter zu erstellen, basierend auf der Liste etwas ähnlich wie diesen (Kredit auf ccm.net rizvisa1) mit: nur

`Sub CreateSheetsFromAList() 
    Dim nameSource  As String 'sheet name where to read names 
    Dim nameColumn  As String 'column where the names are located 
    Dim nameStartRow As Long 'row from where name starts 

    Dim detailSheet As String 'sales detail sheet name 
    Dim detailRange As String 'range to copy from sales detail sheet 

    Dim nameEndRow  As Long 'row where name ends 
    Dim employeeName As String 'employee name 

    Dim newSheet  As Worksheet 

    nameSource = "Pivot" 
    nameColumn = "A" 
    nameStartRow = 5 

    detailSheet = "Pivot" 

    'this is the range where I want to only copy and paste the rows/records that match the new sheet name 
    detailRange = "A5:D463" 


    'find the last cell in use 
    nameEndRow = Sheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row 

    'loop till last row 
    Do While (nameStartRow <= nameEndRow) 
     'get the name 
     employeeName = Sheets(nameSource).Cells(nameStartRow, nameColumn) 

     'remove any white space 
     employeeName = Trim(employeeName) 

     ' if name is not equal to "" 
     If (employeeName <> vbNullString) Then 

      On Error Resume Next 'do not throw error 
      Err.Clear 'clear any existing error 

      'if sheet name is not present this will cause error to leverage 
      Sheets(employeeName).Name = employeeName 

      If (Err.Number > 0) Then 
       'sheet was not there, so it create error, so we can create this sheet 
       Err.Clear 
       On Error GoTo -1 'disable exception so to reuse in loop 

       'add new sheet 
       Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count)) 

       'rename sheet 
       newSheet.Name = employeeName 

       Application.CutCopyMode = False 'clear clipboard 
       'copy sales detail 
       Sheets(detailSheet).Range(detailRange).Copy 

       'paste training material 
       Sheets(employeeName).Cells(1, "A").PasteSpecial 
       Application.CutCopyMode = False 
      End If 
     End If 
     nameStartRow = nameStartRow + 1 'increment row 
    Loop 
End Sub` 

Das hier einzige Problem ist, dass es ich habe kopiert einen statischen Bereich.

Mein Problem ist die Auswahl des Bereichs, in dem die erste Spalte mit dem Blattnamen übereinstimmt, um in das neu erstellte Blatt kopiert und eingefügt zu werden. Ich habe versucht, For Each zu verwenden, wo eine Zelle dem Blattnamen entspricht und die gesamte Zeile kopiert, aber nicht in der Lage war, die Ergebnisse zu erhalten, die ich brauche.

Hier ist, was ich versuche zu tun: in einer Pivot-Tabelle ein Blatt mit folgenden Daten

Nehmen: Pivot

und in neue Blätter mit den Blattnamen aus Spalte A drehen, bevölkerten wobei nur die Daten, die die Blattnamen wie folgt entsprechen:

New sheets with data

Jede Hilfe Sie würde zur Verfügung stellen können sehr geschätzt.

Answer 1

Etwas wie das Folgende sollte funktionieren (nicht getestet).

Sub copyPivotRows() 
Dim pivotRow as Range, wb as Workbook, pivotSheet as Worksheet, dataSheet as Worksheet 
Dim strName as String, rowCount 
Set wb = ActiveWorkbook 
Set pivotSheet = wb.sheets("Pivot") 
For each datasheet in wb.Sheets 
    rowCount = 1 
    For each pivotRow in pivotSheet.usedrange.rows 
     if pivotRow.row > 1 then 
      strName = pivotRow.cells(1).value 
      if datasheet.name = strName then 
       while (datasheet.rows(rowCount).cells(1).value <> "") 
        rowCount = rowCount + 1 
       wend 
       pivotRow.copy datasheet.rows(rowCount) 
       Exit For 
      end if 
      set newSheet = wb.sheets.add(null,datasheet) 
      newSheet.name = strName 
     end if 
    next 'row 
next 'datasheet 
End Sub 

lassen Sie mich wissen, wenn es nicht funktioniert und was sind die Fehler, und ich kann/edit helfen, es selbst jetzt funktioniert, kann es einfach nicht testen.