VBA - Copied Workbook, Pivot Data Source not Updating

[DKoontz]

Hi,

I'm writing a macro that takes a master file, takes a list of sales people, and for each sales person (RSL) creates individual copies of the master file and edits them so that they only see their own data. I've gotten everything to work but the only thing I haven't figured out is how to update the Pivot table data sources. When I make a copy of the workbook, the pivot data source stays linked to the original master instead of updating to the new workbook (which I am then editing). Is there any way to get around this?

This is what the new workbook's pivot table data source points too, it points to the old master file rather than just the Sales table.

I'm still pretty new to VBA so any help is greatly appreciated.

Here is the code I'm using (it still needs some work)

Sub CreateTracings()

Dim Graphs As Worksheet: Set Graphs = Sheets("Graphs")

Dim new_wb As Workbook
Dim UserName As String
Dim myFolder As String
Dim rslName As String
'Dim SalesRange As Range
'Dim HardwareRange As Range
Dim lastRow As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Begin loop
'------------------------------------------------------------------------------|
For i = 1 To Graphs.Range("BA" & Graphs.Rows.Count).End(xlUp).Row
    On Error Resume Next
    
    rslName = Graphs.Range("BA" & i)
    
    'Copy workbook
    ActiveWorkbook.Sheets.Copy
    Set new_wb = ActiveWorkbook
    
    'Edit new workbook
    '*****************************************************
    'Delete Sales Region Trending Tab
    For Each Sheet In new_wb.Worksheets
         If Sheet.Name = "Sales Region Trending" Then
              Sheet.Delete
         End If
    Next Sheet
   
    'Filter and delete in Sales Data
    Dim SalesRange As Range
    Set SalesRange = ActiveWorkbook.Sheets("Sales Data-No Hardware").Range("B2:S" & [SalesData].Cells([SalesData].Rows.Count, 2).End(xlUp).Row)
    SalesRange.AutoFilter Field:=14, Criteria1:="<>" & rslName
    
    On Error Resume Next
        With SalesRange
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
            Err.Clear
    
    'Filter and delete hardware data
    Dim HardwareRange As Range
    Set HardwareRange = ActiveWorkbook.Sheets("Hardware Data").Range("A1:Q" & [HardwareData].Cells([HardwareData].Rows.Count, 1).End(xlUp).Row)
   HardwareRange.AutoFilter Field:=14, Criteria1:="<>" & rslName
    
    On Error Resume Next
        With HardwareRange
            .Offset(1).Resize(.Rows.Count - 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
            Err.Clear
    
    'Refresh all pivot tables
    Calculate
    ActiveWorkbook.RefreshAll
    
    'Saving tracing copy
    UserName = Environ("Username")
    myFolder = "C:\Users\" & UserName & "\Desktop\Field Tracings\"
    
    'Creates Field Tracings folder if missing
    If Dir(myFolder, vbDirectory) = "" Then
         MkDir myFolder
    End If
        
    'Saves Active workbook
    ActiveWorkbook.SaveAs Filename:="C:\Users\" & UserName & "\Desktop\Field Tracings\" & rslName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    'Close activeworkbook
    ActiveWorkbook.Close False
    
On Error GoTo 0
Next i
'------------------------------------------------------------------------------|
'End Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True
    
    
End Sub

[#2]

@DKoontz 

This is a few months later, but did you ever figure out the solution to your problem of updating the Pivot Table data source or a workaround? 

I'm running into the same exact problem. Thanks! 

[#3 · Accepted solution]

@MarissaReyes 

Yes I did! I think I googled every variation of this question before I finally got a solution to work.

The main thing that helped me was creating the updatepivot sub to handle this. It's been a minute since I looked at this, but basically the pivot tables & caches weren't renaming correctly, and were pointing to the old workbook. The updatepivot sub, loops through every pivot table in the workbook and creates a properly named cache. It searches for the "!", splits the names off, and deletes everything before that so you're just left with the correct name and not the "'workbook'!table" mess. 

After calling that, having the workbook calculate and refreshing all seemed necessary. Can't remember but I think the updatepivot sub didn't work on its own without this.

Let me know if this works!

This is my full code:

Sub updatepivot(wb As Workbook)

    Dim pt As PivotTable, ws As Worksheet, ar
    For Each ws In wb.Sheets
        For Each pt In ws.PivotTables
            ar = Split(pt.PivotCache.SourceData, "!")
            If UBound(ar) = 1 Then
               'Debug.Print pt.Name, pt.PivotCache.SourceData, ar(1)
               pt.ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ar(1))
               pt.SaveData = True
            End If
        Next
    Next

End Sub

Sub CreateTracings()

    Dim wsGraphs As Worksheet: Set wsGraphs = Sheets("Graphs")
    Dim new_wb As Workbook, ws As Worksheet
    Dim UserName As String, myFolder As String, rslname As String, TimeTaken As String, myDate As String
    Dim LastRow As Long, i As Long, n As Long
    Dim StartTime As Double
    
    ' Message boxes
    myDate = InputBox("Please Enter Tracings Date: ex. June 2021")
        If (StrPtr(myDate) = 0) Then
            Exit Sub
        End If
    'Debug.Print myDate
 
    ' Start timer
    StartTime = Timer

    ' scan each RSL
    Application.ScreenUpdating = False
    LastRow = wsGraphs.Range("BA" & wsGraphs.Rows.Count).End(xlUp).Row
    For i = 1 To LastRow
        rslname = wsGraphs.Range("BA" & i)
        
        ' Copy workbook
        ActiveWorkbook.Sheets.Copy
        Set new_wb = ActiveWorkbook
        
        ' Delete Sales Region Trending Tab
        Application.DisplayAlerts = False
        For Each ws In new_wb.Worksheets
            If ws.Name = "Sales Region Trending" Then
                ws.Delete
            End If
        Next
        Application.DisplayAlerts = False

         ' Filter and delete from sales data
        Dim SalesRange As Range
        Set SalesRange = new_wb.Sheets("Sales Data-No Hardware").Range("B2:S" & [SalesData].Cells(Rows.Count, 2).End(xlUp).Row)
        SalesRange.AutoFilter Field:=14, Criteria1:="<>" & rslname
    
        On Error Resume Next
        With SalesRange
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete
        End With
        Err.Clear
        On Error GoTo 0
        
        'Filter and delete hardware data
        Dim rngHardware As Range
        Set rngHardware = new_wb.Sheets("Hardware Data").Range("A1:Q" & Sheets("Hardware Data").Cells(Rows.Count, 2).End(xlUp).Row)
        rngHardware.AutoFilter Field:=14, Criteria1:="<>" & rslname
        
        On Error Resume Next
        With rngHardware
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete
        End With
        Err.Clear
        On Error GoTo 0
        
        ' change data source
        Call updatepivot(new_wb)

        'Refresh all pivot tables
        Calculate
        ActiveWorkbook.RefreshAll
        
        'Saving tracing copy
        UserName = Environ("Username")
        myFolder = "C:\Users\" & UserName & "\Desktop\Field Tracings\"
        
        'Creates Field Tracings folder if missing
        If Dir(myFolder, vbDirectory) = "" Then
            MkDir myFolder
        End If
            
        'Saves Active workbook
        rslsavename = rslname & " - " & myDate & " Tracings"
        new_wb.SaveAs Filename:=myFolder & rslsavename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        
        'Close activeworkbook
        new_wb.Close False
        n = n + 1
    Next i
    
    Application.ScreenUpdating = True
    
    TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox n & " workbooks created in " & myFolder & vbNewLine & "Time Taken: " & TimeTaken & " (hours, minutes, seconds)", vbInformation
    
End Sub