VBA to copy multiple pivot tables to one worksheet

[Christopher Keller]

I'm trying to create a macro that will copy multiple pivot tables side by side with varying length (or rows) on more than one worksheet in a workbook, and paste them one after another onto a new worksheet within that workbook. The pivot tables have the same number of columns from the same data source but are filtered based on certain criteria that vary among each pivot table. The reason I want to copy each pivot table to a worksheet is because I want to compare the collective data from the pivot tables to all of the data from the data source to capture any data that may not appear on the pivot tables (to catch any exceptions). I know I can cut and paste the data from the pivot tables and compare to the data source to get what I need, but I am hoping to avoid having to cut and paste the data from each pivot table. That's where the macro/vba I am looking for would be helpful.

 

[D3allamerican07]

Christopher Keller,

Understanding the pivot tables are already compiled, the following code should copy each pivot table and paste them next to each other accordingly. You will need to adjust the names of the sheets to match your workbook however (e.g. "Sheet1" = sheet with the first pivot table, "Sheet2" = sheet with the second pivot table, "Sheet3" = placement of pivot tables.

Also, since the pivot tables are already named, you will need to adjust the names of each as well (e.g. "PivotTable1").

Sub Test()

    Sheets("Sheet1").PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True
        Selection.Copy
        Sheets("Sheet3").Range("A3").Select
        ActiveSheet.Paste
    
    numCol = Sheets("Sheet3").UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column + 2
    letcol = Replace(Cells(1, numCol).Address(False, False), "1", "")
    
    Sheets("Sheet2").PivotTables("PivotTable3").PivotSelect "", xlDataAndLabel, True
        Selection.Copy
        Sheets("Sheet3").Range(letcol & "3").Select
        ActiveSheet.Paste
    
    numCol = Sheets("Sheet3").UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    letcol = Replace(Cells(1, numCol).Address(False, False), "1", "")
    
    ActiveSheet.Columns("A:" & letcol).AutoFit
End Sub

Let me know if you have any issues.

Bill

 

[Christopher Keller]

Thanks Bill. I have 7 worksheets, eachworksheet with multiple pivot tables I want to copy and paste to aseparate worksheet. Can you get me started on how to adapt thisinformation in the code you provided if I give you the name ofsay worksheets 1-3 of the 7 worksheets, and the names ofthose pivot tables on each of worksheet 1-3? If you can provide thatinformation, I think I can follow the methodology to complete the rest ofthe code (for worksheets and their pivot table names forworksheets 4 through 7). Also, can you confirm the codeprovided will copy and paste the placement of the pivot tables under eachother not next to each other? The worksheet names andpivot table names for worksheet 1-3 are as follows:

Worksheet 1 is named BU fringe with 4 pivot tables named 1-4
Worksheet 2 is named OPERATIONS with 8 pivot tables named 1-8
Worksheet 3 is named Facilities with 19 pivot tables named 1-7,9-20 (pivot table 8 does not exist)<o></o>

 

[D3allamerican07]

Christopher Keller,

The script has been adjusted to account for your first 3 sheets. You can follow the same loop to add the last 4 sheets and their pivot tables. Just adjust the i variable to fit the pivot table numbers and the sheet name accordingly. Also, I created a SUMMARY sheet for the pivot tables to be pasted in. If that name is different than yours, it will have to be changed as well.

Sub Test()

    'Makes code run faster
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'For BU fringe Sheet
    For i = 1 To 4
        LR = Sheets("SUMMARY").Range("A" & Rows.Count).End(xlUp).Row
            
        Sheets("BU fringe").Activate
        
        Sheets("BU fringe").PivotTables("PivotTable" & i).PivotSelect "", xlDataAndLabel, True
            Selection.Copy
        Sheets("SUMMARY").Activate
            Sheets("SUMMARY").Range("A" & LR + 2).Select
            ActiveSheet.Paste
    Next i
    
    'For OPERATIONS Sheet
    For i = 1 To 8
        LR = Sheets("SUMMARY").Range("A" & Rows.Count).End(xlUp).Row
            
        Sheets("OPERATIONS").Activate
        
        Sheets("OPERATIONS").PivotTables("PivotTable" & i).PivotSelect "", xlDataAndLabel, True
            Selection.Copy
        Sheets("SUMMARY").Activate
            Sheets("SUMMARY").Range("A" & LR + 2).Select
            ActiveSheet.Paste
    Next i
    
    'For Facilities Sheet
    For i = 1 To 7
        LR = Sheets("SUMMARY").Range("A" & Rows.Count).End(xlUp).Row
            
        Sheets("Facilities").Activate
        
        Sheets("Facilities").PivotTables("PivotTable" & i).PivotSelect "", xlDataAndLabel, True
            Selection.Copy
        Sheets("SUMMARY").Activate
            Sheets("SUMMARY").Range("A" & LR + 2).Select
            ActiveSheet.Paste
    Next i
    
    'For Facilities Sheet
    For i = 9 To 20
        LR = Sheets("SUMMARY").Range("A" & Rows.Count).End(xlUp).Row
            
        Sheets("Facilities").Activate
        
        Sheets("Facilities").PivotTables("PivotTable" & i).PivotSelect "", xlDataAndLabel, True
            Selection.Copy
        Sheets("SUMMARY").Activate
            Sheets("SUMMARY").Range("A" & LR + 2).Select
            ActiveSheet.Paste
    Next i
        
    'Formatting pivot tables for column adjustment
    numCol = Sheets("SUMMARY").UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    letcol = Replace(Cells(1, numCol).Address(False, False), "1", "")
    
    Sheets("SUMMARY").Activate
    
    ActiveSheet.Columns("A:" & letcol).AutoFit
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Let me know if this works for you.

Bill

 

[Christopher Keller]

Bill, thanks a ton! It worked great. I really appreciate your help.

 

[D3allamerican07]

Christopher,

No problem, glad it was what you were looking for.

Bill