基于列表创建工作表并填充与工作表名称匹配的列的数据

Question

我一直在编写一个工作簿，以根据数据透视表中的值创建和填充工作表。

我使用与此类似的方法根据列表创建工作表（归功于 ccm.net 上的 rizvisa1）：

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

我只复制了一个静态范围。

我的问题是选择第一列与工作表名称匹配的范围，以便复制并粘贴到新创建的工作表中。我尝试使用For Each，其中一个单元格与工作表名称匹配并复制整行。

这就是我想要做的：

在数据透视表中获取包含以下数据的工作表：

然后将其转换为具有 A 列工作表名称的新工作表，仅填充与工作表名称匹配的数据，如下所示：

带有数据的新工作表

Answer 1

有几种方法。它A列包含工作表名称，然后您可以对工作表名称进行过滤，然后复制范围。在 CCM 上，您会找到该解决方案。基本上，您将复制第一列的不同值，以了解如何创建哪些工作表。过滤每个值然后复制到新工作表

Answer 2

类似下面的东西应该可以工作（未经测试）。

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

让我知道它是否不起作用以及错误是什么，我可以帮助/编辑使其起作用，只是现在无法自己测试。