将数据透视表从同名工作表复制到另一个工作簿

Question

我试图仅从 data.xlsm 文件中每个工作表上的 9 个数据透视表中获取值，以复制到地区文件中相应的工作表名称（当前有 12 个地区在两个工作簿中具有相同的工作表）。但是，我从 data.xlsm 中获取每个工作表中的所有数据透视表，并将其复制到区文件中的每个工作表中。

有没有办法仅在每个工作簿中的工作表名称相同的情况下获取数据透视表值？例如，从数据中的 Pacifa 工作表到区域中的 Pacifica 工作表的所有枢轴。

这是我目前拥有的。

    Sub pivots()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

     Dim wbook As Workbook
     Dim strName As String



     'Clear Contents
     Set dbook = Workbooks("District.xlsm")

        For Each sht In dbook.Worksheets
           sht.Activate
           sht.Cells.Select
            Selection.ClearContents
            sht.Cells(1, 1).Select ' edit: select the first cell to cancel selection of the whole sheet
        Next sht


    'Checks for matching sheet names in both workbooks if it matches then loops over each sheet to copy and paste each pivot table to corresponding sheet without linking the source data
Set wbook = Workbooks("data.xlsm")

     On Error Resume Next

    
      For Each sht In wbook.Worksheets
                For i = 1 To 9
                 LR = dbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
                    sht.Activate
                    sht.PivotTables("PivotTable" & i).PivotSelect "", xlDataAndLabel, True
                    Selection.Copy
                 
            Next i
    ' Pastes values into Districts excel workbook
                For Each Ws In dbook.Worksheets
                   For s = 1 To 12
                    Ws.Activate
                    Ws.Worksheets ("Sheet" & s)
                    Ws.Range("A" & LR).Select
                   Ws.PasteSpecial (xlPasteValuesAndNumberFormats)
              Next s
        
        
        Next Ws
    
       Next sht

     MsgBox "done!"


    'Formatting pivot tables for column adjustment
     numCol =     Workbooks("District.xlsm").Sheets("Northland").UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column

letcol = Replace(Cells(1, numCol).Address(False, False), "1", "")
    
Workbooks("District.xlsm").Activate
    
ActiveSheet.Columns("A:" & letcol).AutoFit

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
'Function to check for same sheet name
Function SheetExists(strName As String, wkbS As Workbook)

    Dim sh As Worksheet

    On Error Resume Next

    Set sh = wbook.Worksheets(strName)

    SheetExists = (Err = 0)

End Function

Answer 1

• 使用

  Option Explicit

  强制显式声明该模块中的所有变量。这有助于避免一些编码错误。

注意： 由于缺乏测试数据，代码未经过测试。

Option Explicit
Sub pivots()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim wBook As Workbook, dataSht As Worksheet
    Dim strName As String, dBook As Workbook
    Dim Sht As Worksheet, i As Long, LR As Long
    'Clear Contents
    Set dBook = Workbooks("District.xlsm")
    dBook.Activate
    For Each Sht In dBook.Worksheets
        Sht.Cells.ClearContents
    Next Sht
    Set wBook = Workbooks("data.xlsm")
    ' Loop through all sheets in data.xlsm
    For Each Sht In wBook.Worksheets
        ' Check same sheet in District.xlsm
        If SheetExists(Sht.Name, dBook) Then
            Set dataSht = dBook.Sheets(Sht.Name)
            dataSht.Select
            For i = 1 To 9
                Sht.PivotTables("PivotTable" & i).TableRange1.Copy
                LR = dataSht.Range("A" & dataSht.Rows.Count).End(xlUp).Row
                If LR = 1 Then LR = 0
                ' Select the first blank cell in col A
                dataSht.Range("A" & LR + 1).Select
                dataSht.PasteSpecial xlPasteValuesAndNumberFormats
            Next i
        End If
    Next Sht
    MsgBox "done!"
    'Formatting pivot tables for column adjustment
    Workbooks("District.xlsm").Sheets("Northland").UsedRange.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
'Function to check for same sheet name
Function SheetExists(strName As String, wBook As Workbook)
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = wBook.Worksheets(strName)
    SheetExists = (Err = 0)
End Function