VBA - Macro Copied Workbook, Pivot Data Source not Updating, Error with Pivot Cache?

Question

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? I've looked and a few different people are suggesting its an issue with pivot caches but I've had no luck with any fixes.

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. Feels so close to working properly.

As a quick run-through of the macro it should, for each sales person in list on "graphs" tab > copy master > Delete sales region trending tab > delete everyone but that sales person from sales data > delete everyone but that sales person in hardware data > refresh all pivot tables > save as a copy in a desktop field tracings folder > close.

Side question: Does it matter where you define a DIM, in/outside a loop if its being changed each loop?

Edit: Here is my final working macro

     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 CreateTracingsStack()

    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 box
    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
 
    ' Determine range addresses
    Dim addrSales As String, rngSales As Range
    With Sheets("Sales Data-No Hardware")
        LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        addrSales = .Range("B2:S" & LastRow).Address
    End With
    'Debug.Print "SalesData LastRow", LastRow, addrSales
 
    Dim addrHardware As String, rngHardware As Range
    With Sheets("Hardware Data")
        LastRow = Sheets("Hardware Data").Cells(Rows.Count, 2).End(xlUp).Row
        addrHardware = Sheets("Hardware Data").Range("A1:Q" & LastRow).Address
    End With
    'Debug.Print "HarwareData LastRow", LastRow, addrHardware

    ' 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([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).Delete
        End With
        Err.Clear
        On Error GoTo 0
        
        'Filter and delete hardware data
        Set ws = new_wb.Sheets("Hardware Data")
        Set rngHardware = ws.Range(addrHardware)
        rngHardware.AutoFilter Field:=14, Criteria1:="<>" & rslname
        
        On Error Resume Next
        With rngHardware
            .Offset(1).Resize(.Rows.Count - 0).SpecialCells(xlCellTypeVisible).Delete
        End With
        Err.Clear
        On Error GoTo 0
        ws.AutoFilterMode = False
        
        ' 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

Answer 1

If you have named ranges try removing the external reference part of the source data.

Update - using ChangePivotCache

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))
            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
    Dim LastRow As Long, i As Long, n As Long
 
    ' determine range addresses
    Dim addrSales As String, rngSales As Range
    With Sheets("Sales Data-No Hardware")
        LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        addrSales = .Range("B2:S" & LastRow).Address
    End With
    'Debug.Print "SalesData LastRow", LastRow, addrSales
 
    Dim addrHardware As String, rngHardware As Range
    With Sheets("Hardware Data")
        LastRow = Sheets("Hardware Data").Cells(Rows.Count, 2).End(xlUp).Row
        addrHardware = Sheets("Hardware Data").Range("A1:Q" & LastRow).Address
    End With
    'Debug.Print "HarwareData LastRow", LastRow, addrHardware

    ' 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 = True
       
        'Filter and delete in Sales Data
        Set ws = new_wb.Sheets("Sales Data-No Hardware")
        Set rngSales = ws.Range(addrSales)
        rngSales.AutoFilter Field:=14, Criteria1:="<>" & rslname
        
        On Error Resume Next
        With rngSales
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        Err.Clear
        On Error GoTo 0
        ws.AutoFilterMode = False
        
        'Filter and delete hardware data
        Set ws = new_wb.Sheets("Hardware Data")
        Set rngHardware = ws.Range(addrHardware)
        rngHardware.AutoFilter Field:=14, Criteria1:="<>" & rslname
        
        On Error Resume Next
        With rngHardware
            .Offset(1).Resize(.Rows.Count - 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        Err.Clear
        On Error GoTo 0
        ws.AutoFilterMode = False
        
        ' change data source
        Call updatepivot(new_wb)

        'Refresh all pivot tables
        Calculate
        new_wb.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
        new_wb.SaveAs Filename:=myFolder & rslname, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        
        'Close activeworkbook
        new_wb.Close False
        n = n + 1
    Next i
    Application.ScreenUpdating = True
    MsgBox n & " workbooks created in " & myFolder, vbInformation
    
End Sub