VBA - Copying Worksheets that contain Pivot tables

[artfulldodger]

Hi all,

I have some VBA that copies some Worksheets from a template file into 36 other files. All files are exactly the same other than the filenames which are created as the macro runs.

One of the worksheets it copies contains all the pivot tables. The issue I am having is that for every copy, it is keeping the original Source Data range in the Pivot tables." '\Users\Username\Desktop\2023 MI Project\Templates\MI Template.xlsm'!Table2"

I want the copied worksheets\pivots to just reference "Table2" as an example.

Any idea how this is can be done?

Here is my code I am using:

Sub CreateCustomerWorkbooks()

Dim customerListBook As Workbook
Dim customerListSheet As Worksheet
Dim customerName As String
Dim customerWorkbook As Workbook
Dim reportsFolder As String
Dim i As Long

'Change this to the file path of your customer list
Set customerListBook = Workbooks.Open("C:\Users\Username\Desktop\2023 MI Project\Customer List\Customer list.xlsx")
Set customerListSheet = customerListBook.Sheets("Sheet1")

'Change this to the folder path where you want to save the customer workbooks
reportsFolder = "C:\Users\Username\Desktop\2023 MI Project\Reports\"

'Open the MI Template workbook to copy the sheets
Dim templateWorkbook As Workbook
Set templateWorkbook = Workbooks.Open("C:\Users\Username\Desktop\2023 MI Project\Templates\MI Template.xlsm")

'Loop through each customer in the list
For i = 1 To customerListSheet.Range("A" & Rows.Count).End(xlUp).Row
customerName = customerListSheet.Range("A" & i).Value

'Create a new workbook for the customer
Application.DisplayAlerts = False 'Disable the display of alert messages
Set customerWorkbook = Workbooks.Add
customerWorkbook.SaveAs reportsFolder & customerName & ".xlsx", FileFormat:=51 '51 is the code for .xlsx file format

'Copy the sheets from the template workbook to the customer workbook
templateWorkbook.Sheets.Copy After:=customerWorkbook.Sheets(customerWorkbook.Sheets.Count)

'Delete the default sheet in the customer workbook
Application.DisplayAlerts = False 'Disable the display of alert messages
customerWorkbook.Sheets("Sheet1").Delete
Application.DisplayAlerts = True 'Enable the display of alert messages

'Enter the customer name into the Import.Data worksheet
customerWorkbook.Sheets("Import.Data").Range("E5").Value = customerName

'Update all connections in the customer workbook to the new workbook
Dim conn As WorkbookConnection
For Each conn In customerWorkbook.Connections
conn.OLEDBConnection.Connection = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & customerWorkbook.FullName & ";Mode=Share Deny Write;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"
conn.Refresh
Next conn

'Close the customer workbook
customerWorkbook.Close True 'Save changes

Next i

'Close the template workbook without prompting to save changes
Application.DisplayAlerts = False
templateWorkbook.Close False
Application.DisplayAlerts = True

'Close the customer list
customerListBook.Close

'Inform user when the process is complete
MsgBox "Empty Customer Reports Created!"

 

[Alex Blakenburg]

Try inserting this code before saving & closing the customer workbook.

'for normal pivot tables only
'not for OLAP-based (e.g. Data Model)
Dim ws As Worksheet
Dim pt As PivotTable
Dim strDataSrc As String

For Each ws In customerWorkbook.Worksheets
  For Each pt In ws.PivotTables
      strDataSrc = pt.SourceData
   
      If InStr(1, strDataSrc, "[") = 0 Then       ' Check for sheet name in address
          ' Handle Table or Named Range
          strDataSrc = Right(strDataSrc, Len(strDataSrc) - InStrRev(strDataSrc, "!"))
           
      Else
          ' Range Address
          strDataSrc = Right(strDataSrc, Len(strDataSrc) - InStrRev(strDataSrc, "]"))
          If InStr(strDataSrc, "'") Then strDataSrc = "'" & strDataSrc
      End If
          
      pt.ChangePivotCache wb.PivotCaches.Create _
          (SourceType:=xlDatabase, SourceData:=strDataSrc, Version:=8)
   
      pt.RefreshTable

  Next pt
Next ws