Jul 28 2021 01:48 PM - edited Jul 28 2021 03:01 PM
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
Nov 30 2021 08:12 AM
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!
Nov 30 2021 10:51 AM
SolutionYes 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
Nov 30 2021 10:51 AM
SolutionYes 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