根据列表创build图纸并仅填充列匹配图纸名称的数据

我一直在努力让工作簿创build工作表并根据数据透视表中的值填充这些工作表。 通过我的各种search，我已经能够使用类似的东西（在ccm.net上的信用rizvisa1）基于列表创build表单：

`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` 

这里唯一的问题是，我只是在复制一个静态范围。

我的问题是select第一列匹配工作表名称的范围，以复制并粘贴到新创build的工作表。 我已经尝试使用For Each ，其中一个单元格匹配表名称并复制整个行，但一直没有能够得到我需要的结果。

这是我想要做的：

使用数据透视表中的以下数据表单： 透视

并将其转换为新的工作表，使用列A中的工作表名称填充只有与工作表名称匹配的数据，如下所示：

带有数据的新表单

任何帮助，您可以提供将不胜感激。

Answer 1

像下面的东西应该工作（没有testing）。

 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 

让我知道，如果它不工作，错误是什么，我可以帮助/编辑，使其工作，只是不能现在就自己testing。