Excel VBA to create new PivotCache and connect multiple Pivot Tables - excel

I have a workbook with many pivot tables that are based on a range that is deleted and refreshed using VBA. Currently, to update the data source, as the last part of that sub routine, I recreate PivotCaches for each PivotTable and refresh.
I want just 6 of the tables to be linked together with one common PivotCache so they can share slicers etc and I cannot get it working.
I have looked all over for a solution to this but I keep coming up short and I have been stuck on it for a fair while now. I am reasonably new to VBA but I can usually work it out with trial and error but this one just has me stumped.
I obviously have done something wrong and any help to identify what, would be greatly appreciated.
Thanks :)
My current code is below (Note: I removed the non-related stuff from the code for ease of reading):
Sub RunReport()
On Error GoTo ErrorHandler
'############## Define Variables ##############
Dim WS_O As Worksheet 'Output sheet - report sheet
Dim WS_P As Worksheet 'Pivot table Sheet
Dim OuputRow As Integer 'First row for output of data
Dim LastRow_O As Integer 'Last used row of output sheet
Dim PivotCacheName As PivotCache
Dim PivotRange As String 'Range of data for Pivot Data Source
Dim PivotName1 As String 'Pivot Table Name Strings
Dim PivotName2 As String
Dim PivotName3 As String
Dim PivotName4 As String
Dim PivotName5 As String
Dim PivotName6 As String
'############## Modify Application Settings ##############
'Store current configuration
OriginalCalcMode = Application.Calculation
'Set configuration for fastest processing
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
'############## Set Variable Values ##############
'Worksheets
Set WS_O = Sheets("Report") 'Output sheet - report sheet
Set WS_P = Sheets("Pivot Tables - Live Data") 'Pivot tables sheet
'Pivot Tables
PivotName1 = "PivotTable1"
PivotName2 = "PivotTable2"
PivotName3 = "PivotTable3"
PivotName4 = "PivotTable4"
PivotName5 = "PivotTable5"
PivotName6 = "PivotTable6"
'General
OutputRow = 7
'Used Ranges
LastRow_O = WS_O.Range("A" & Rows.Count).End(xlUp).Row
'############## Refresh Pivot Tables ##############
'Define Data Range
PivotRange = WS_O.Name & "!" & "A" & OutputRow - 1 & ":AM" & LastRow_O
'Error Handling
'Make sure every column in data set has a heading and is not blank
If WorksheetFunction.CountBlank(WS_O.Range("A" & OutputRow - 1 & ":AM" & LastRow_O).Rows(1)) > 0 Then
MsgBox "One or more columns in ''Report'' sheet has a blank heading;" & vbNewLine _
& "This has prevented the pivot tables from refreshing correctly." & vbNewLine & vbNewLine _
& "Please verify cells A" & OutputRow - 1 & ":AM" & OutputRow - 1 & " in ''Report'' sheet are not blank and try again.", vbCritical, "ERROR - Column Heading Missing"
GoTo EndSub
End If
'Change Pivot Data Sources to a single cache
Set PivotCacheName = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange, Version:=xlPivotTableVersion15)
WS_P.PivotTables(PivotName1).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName2).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName3).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName4).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName5).ChangePivotCache (PivotCacheName)
WS_P.PivotTables(PivotName6).ChangePivotCache (PivotCacheName)
'Refresh Pivot Tables
'Turn on auto calc while pivot's update
Application.Calculation = xlCalculationAutomatic
WS_P.PivotTables(PivotName1).RefreshTable
WS_P.PivotTables(PivotName2).RefreshTable
WS_P.PivotTables(PivotName3).RefreshTable
WS_P.PivotTables(PivotName4).RefreshTable
WS_P.PivotTables(PivotName5).RefreshTable
WS_P.PivotTables(PivotName6).RefreshTable
'Completion Confirmation
MsgBox "Report data has been compiled and pivot tables have been successfully refreshed.", vbInformation, "SUCCESS! - Report Compilation Complete"
'############## End Sub and Reset Application Configuration ##############
'Standard End Sub Functionality (where no undocumented error occurred)
EndSub:
Application.ScreenUpdating = False
Application.Calculation = OriginalCalcMode 'Reset calc option to what it was previously
Application.EnableEvents = True
Exit Sub
'Error Handling (where an undocumented error occurred - that is, an error without an explainatory message box)
ErrorHandler:
Application.ScreenUpdating = False
' Application.Calculation = OriginalCalcMode
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "An error caused this subroutine to stop working correctly." & vbNewLine _
& "Contact Administrator for assistance.", vbCritical, "ERROR - Contact Administrator"
End Sub
I was previously using this and still am for some tables I don't want using the same PivotCache:
'Create new caches for each table
WS_P.PivotTables(PivotName1).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName2).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName3).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName4).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName5).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
WS_P.PivotTables(PivotName6).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
I'm currently getting the Runtime 438 Error (Object doesn't support this property or method) here >>>
WS_P.PivotTables(PivotName1).ChangePivotCache (PivotCacheName)
EDIT: I have found a solution and added an answer below.

So, after a good nights sleep and several more hours of research, I have what I believe to be a solution.
It's probably not the best way, but it works and hasn't yet caused me any issues...
'Create New Pivot Cache from Data Range
WS_P.PivotTables(PivotName1).ChangePivotCache _
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PivotRange)
'Link Other Pivot Tables to same Pivot Cache
WS_P.PivotTables(PivotName2).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName3).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName4).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName5).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
WS_P.PivotTables(PivotName6).CacheIndex = WS_P.PivotTables(PivotName1).CacheIndex
I'm still not sure why the other way wasn't working so would still appreciate some feedback, if anyone has any as this method does prohibit me attaching slicers to all pivot tables (I have to leave the first one out).

Related

VBA Efficiency for Larger Data Sets

I created an Excel spreadsheet that allows users to input data. Then it takes formulas from a seperate tab, and pastes them in to the data set tab. It then sorts all of them in a specific order which is needed for the process it is used for.
I have tried to increase the efficiency by turning off automatic calcs and only calculating when I need to, then pasting values after that. I have also turned off screen updating, status bar, and enable events. I think these are some of the low hanging fruit.
It works pretty well for smaller datasets (say 25K rows and smaller) but it can really get bogged down with larger ones. I have one in particular that is 48K rows and it often will just end up freezing my Excel.
Any spots jumping out that could be altered to increase efficiency?
--
Worksheets("Update Indicator").Visible = True
Sheets("Update Indicator").Range("B1") = 1
Dim LossSort As Workbook
Dim WC As Worksheet
Dim WC_Form As Worksheet
Dim lastRow As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Set LossSort = ThisWorkbook
Set WC = LossSort.Sheets("WC Losses")
Set WC_Form = LossSort.Sheets("WC Formulas")
If WC.AutoFilterMode Then
WC.AutoFilterMode = False
End If
lastRow = WC.Range("V" & Rows.Count).End(xlUp).Row
'Code to help speed up macro
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
Calculate
'Test if the value in cell U2 is blank/empty
If IsEmpty(WC.Range("W2").Value) = True Then
MsgBox "No WC Losses Available"
Exit Sub
Else
End If
'Set Original Order
WC.Range("BH2") = 1
WC.Range("BH2:BH" & lastRow).DataSeries , xlDataSeriesLinear
'Copy formulas from WC Formulas tab to WC Losses
WC_Form.Range("A2:U2").Copy Destination:=WC.Range("A2:U" & lastRow)
WC_Form.Range("AX2:BG2").Copy Destination:=WC.Range("AX2:BG" & lastRow)
'Calculate
WC.Calculate
'Apply formatting across the dataset
WC_Form.Range("L2:AM2").Copy
WC.Range("L2:O" & lastRow).PasteSpecial Paste:=xlPasteFormats
'Sort by Acc Desc and Claim# then by Closed No Pay, Loss Date, State
With Sheets("WC Losses").Cells(1, 1).CurrentRegion.Cells
.Sort Key1:=Range("Z1"), Order1:=xlAscending, _
Key2:=Range("V1"), Order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
With Sheets("WC Losses").Cells(1, 1).CurrentRegion.Cells
.Sort Key1:=Range("K1"), Order1:=xlAscending, _
Key2:=Range("W1"), Order2:=xlAscending, _
Key3:=Range("X1"), Order3:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
'Paste values over formulas
WC.Calculate
Dim rng1 As Range
Set rng1 = WC.Range("A2:T" & lastRow)
WC.Range("A2").Resize(rng1.Rows.Count, rng1.Columns.Count).Cells.Value = rng1.Cells.Value
Dim rng2 As Range
Set rng2 = WC.Range("AX2:BG" & lastRow)
WC.Range("AX2").Resize(rng2.Rows.Count, rng2.Columns.Count).Cells.Value = rng2.Cells.Value
Sheets("Update Indicator").Range("C5").Copy Destination:=Sheets("Update Indicator").Range("B5")
Sheets("Update Indicator").Calculate
Sheets("Update Indicator").Range("B5").Copy
Sheets("Update Indicator").Range("B5").PasteSpecial Paste:=xlPasteValues
Worksheets("Update Indicator").Visible = False
finish:
ActiveWorkbook.RefreshAll
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
I would start by formatting your data as a Table and allowing it to manage your formulas. That way you avoid all the VBA you're using to copy and paste your formulas.
You could also try using Power Query to handle the formulas and sorting and avoid most of the VBA you're using.
Also, if you're going to turn off calc, screenupdating, events etc., you've got to have error handling to make sure that is your code fails, they all get reset back to their defaults. Otherwise, you can end with Excel in a REALLY bad state.

Using Excel VBA to retrieve data from multiple MS Project Files

I have ran into an automation issue that I cannot seem to figure out.
Currently, I have a worksheet,("Project") that contains data in columns "A"(Project Name) & "B"(Project File Location).
Column "B" contains the string location of each MS Project file.
My VBA macro loops through column "B" and opens each MS Project file and copies a task with the .SelectTaskField method and then copies it back into column "E" of the worksheet.
The first 2 projects loop through without any issues, however, on the 3rd project, I receive the Run-time error '1004': An unexpected error occurred with the method.
I co-worker and I have poured through the code and the MS Project Files to see if there are any differences in the data and we cannot find any differences.
Below is a copy of the code that I have been using.
Just wanted to see if anyone else has had similar issues. I have found that MS Project does not like to be manipulated like Excel or Word.
Any help would be greatly appreciated.
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
'Turns off updates and alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Select Daily Field Reports and clear worksheet
ws.Range("E2:E" & lrow).ClearContents
'Opens MS Project
Set objproject = CreateObject("MSProject.Project")
'This keeps MS Project invisible. If you want to see it, change to "True"
objproject.Application.Visible = True
Dim oproject As Range
'This cycles through the range and gathers the data for each project
For Each oproject In Range("B2:B" & lrow)
Set objproject = CreateObject("MSProject.Project")
oproject.Select
objproject.Application.FileOpen Selection
objproject.Application.Visible = True
objproject.Application.SelectTaskField Row:=1, Column:="Percent Complete", RowRelative:=False 'The column name must match. This is the only issue that I have uncovered.
objproject.Application.EditCopy
ws.Select
Dim lastrow As Long
lastrow = ws.Cells(Rows.Count, "E").End(xlUp).Row + 1
Dim Rng As Range
Set Rng = ws.Range("E" & lastrow)
'Rng.PasteSpecial xlPasteFormats
Rng.PasteSpecial xlPasteValues
objproject.Application.Quit
Next oproject
'Turns updates and alerts back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Closes MS Project
objproject.Application.Quit
End Sub
Using the SelectTaskField method presumes the file was saved in a task view and that the column you want is in the table of the view. Better to get the values you need directly from the Task object.
It appears you are looking for the % Complete value from the first task. In that case use this:
objproject.ActiveProject.Tasks(1).PercentComplete
Here's how it could work in your code. I took the liberty of simplifying it a bit:
Sub Test()
Dim ws As Worksheet
Set ws = Worksheets("Projects")
Dim lrow As Long
lrow = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ws.Range("E2:E" & lrow).ClearContents
Dim objproject As MSProject.Application
Set objproject = CreateObject("MSProject.Application")
objproject.Application.Visible = True
Dim oproject As Range
For Each oproject In Range("B2:B" & lrow)
objproject.FileOpen Name:=oproject.Value, ReadOnly:=True
oproject.Offset(, 3) = objproject.ActiveProject.Tasks(1).PercentComplete
objproject.FileCloseEx
Next oproject
Application.ScreenUpdating = True
Application.DisplayAlerts = True
objproject.Quit
End Sub
Note that it is more straight-forward to get a reference to the application object rather than a child of that object: CreateObject("MSProject.Application") is preferable to CreateObject("MSProject.Project").

VBA: Updating Pivots Issues

I am relatively new to VBA, at the moment when trying to update a pivot, I get the following error Run-time error 1004,
The Pivot seems not to be taking the data set correctly as on the pivot there are missing dates which are correctly formatted on the Dataset.
When I run the macro it stops right on DateVal line, please feel free to ask for more details if needed.
I tried adding manually dates that are part of the dataset with the same result but if I select dates running the Record Macro it'll work but and the if I run the macro created by the Recorder I would get the same Error, I hope you can show me where I am wrong on this code.
Sub UpdatePivots()
Application.ScreenUpdating = False
Dim DateVal As String
DateVal = Sheets("home").[G16]
DateFormat = Sheets("home").[Q10]
' Find the last row with data in column A
Sheets("GLViewFinanceCycleCounts").Select
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False 'Remove Filters if exists
LastRow = ActiveSheet.Range("C1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row
pName = ActiveWorkbook.Path ' the path of the currently active file
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
DatasetRange = Range("A1:BM" & LastRow).Address(ReferenceStyle:=xlR1C1)
DatasetPT = pName & "\[" & wbName & "]" & shtName & "!" & DatasetRange
' Pivot Updates
' CompletesAndSH page
Sheets("CompletesAndSH").Select ' Pivot Table Page
ActiveSheet.PivotTables("PivotTable41").ChangePivotCache ActiveWorkbook. _
PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DatasetPT, Version:= _
xlPivotTableVersion14)
ActiveWorkbook.RefreshAll
' Filter to selected month
ActiveSheet.PivotTables("PivotTable41").PivotFields("A$Period Name").ClearAllFilters
ActiveSheet.PivotTables("PivotTable41").PivotFields("A$Period Name").CurrentPage = DateVal

VBA: Tickbox - True, creates a sheet. False, deletes the sheet

I am editing an existing template in VBA. This template organises data from a "Raw Data" sheet into a "Day", "Evening" and "Night" sheet. I want to create a sheet called "Weekend", where data from "Raw Data" will be copied to if the date is not a weekday (i know how to do that bit).
However, the amount of data that runs through this template is massive, so to avoid creating a weekend sheet where the user does not need/want one I want to put in a section of code where if a tick box is ticked (True), a sheet called "Weekend" will be created (within the workbook, but inbetween existing sheets - namely inbetween a sheet called "Night" and "Graph - All Data") and when it is unticked (False) this sheet will not exist.
I thought about having this sheet to exist all the time, and to have it hidden when the tick box is unticked, however this means that the data would be still piled into it and in the interest of efficiency I would rather not have it like that.
Here is the Code I am trying to alter
Sub ToggleWindDirection()
Dim i As Long
Application.ScreenUpdating = False
If sheetArr(1) Is Nothing And LastNDRow = Empty Then
DefineLists
End If
Sheets("Raw Data").Unprotect Password:="2260"
For Each sht In sheetArr
sht.Unprotect Password:="2260"
Next
Set chtAllData = ActiveWorkbook.Charts("Graph - All Data")
With Sheets("Raw Data")
If .Range("O15").Value = True Then
'Wind direction is being used
.Range("C17:G17").Font.ColorIndex = xlAutomatic
.Range("D17").Font.ColorIndex = 9
.Range("G17").Font.ColorIndex = 9
.Range("D17").Locked = False
.Range("G17").Locked = False
.Range("F" & FirstNDRow & ":F10000").Interior.Pattern = xlNone
.Range("F" & FirstNDRow & ":F10000").Interior.PatternTintAndShade = 0
.Range("F" & FirstNDRow & ":F10000").Font.ColorIndex = xlAutomatic
Else
'Not using wind direction
.Range("C17:G17").Font.ColorIndex = 16
.Range("D17").Locked = True
.Range("G17").Locked = True
.Range("F" & FirstNDRow & ":F10000").Interior.Pattern = xlSolid
.Range("F" & FirstNDRow & ":F10000").Interior.TintAndShade = -4.99893185216834E-02
.Range("F" & FirstNDRow & ":F10000").Font.ColorIndex = 16
End If
'Addition by lewisthegruffalo 2016
Dim ws As Worksheet
If .Range("O21").Value = True Then
'create the weekend sheet
Set ws = Worksheets.Add(After:=Worksheets("Night"))
ws.Name = "Weekend"
Else
'No Weekend needed
Worksheets("Weekend").Delete
End If
End With
Sheets("Raw Data").Activate
Application.ScreenUpdating = True
End Sub
Any help would be greatly apprichiated.
Kind Regards,
lewisthegruffalo
If you want to create a new sheet using sheets.add then you can utilise the arguments in it to tell it where to put it, the msdn page has a good example at the bottom.
What you have so far? Where do you wanna call it? What checkbox shall be ticked? Please provide some code.
A general answer is this to add a new worksheet:
Dim ws As Worksheet
If Something Then
Set ws = Worksheets.Add(Before:=Worksheets("Graph - All Data"))
ws.Name = "Weekend"
'do anything you want with the ws object
End if

Merge multiple PivotTables for multiple workbooks to create a master PivotTable

I've found a code that I've (mostly) successfully modified for my use, but am getting an error on the grouping function. I have a folder that has (at present) three workbooks in them. Each workbook is formatted exactly the same from sheet names to fields within each sheet. Each workbook has two PivotTables derived from the same unique data source (a third sheet in the workbook).
I need to be able to, in a new workbook, run a script that will allow me to choose the workbooks from the common folder that I want to combine into one master pivot table. My source data looks like this:
(slashes used after the names for each column and after the data in row 2 are only there to differentiate the different columns (12 in total, A to L inclusive))
Row 1 - Line / Sort / Sub-Cat / Part / Para / Page / Deliv / Action / Owner / DueDate / Status / DateComp
Row 2 - 2 / b / Confrnc / 2 / 2.2.1 / 8 / Attend / Attend / John / 23-May-13 / NotStarted / (blank)
Each workbook has a data source sheet set up exactly like this, with multiple rows of data.
Each workbook has a pivot table that compiles:
ROWS:
Sub-Cat;
Action;
Owner;
Status
COLUMNS:
DueDate
VALUES:
Count of Action
I have the following piece of code that I have modified to meet my needs copied and pasted into a new Module in a new workbook (saved in the same folder as my source workbooks):
Option Explicit
Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal Path As String) As Long
'---------------------------------------------------------------------------------------
' Author: Rob Bovey
'---------------------------------------------------------------------------------------
Sub ChDirNet(Path As String)
Dim Result As Long
Result = SetCurrentDirectoryA(Path)
If Result = 0 Then Err.Raise vbObjectError + 1, "Error changing to new path."
End Sub
'---------------------------------------------------------------------------------------
' Procedure : MergeFiles
' Author : KL
' Date : 22/08/2010
' Purpose : Demonstration (http://www.planetaexcel.ru/forum.php?thread_id=18518)
' Comments : Special thanks to
' Debra Dalgleish for helping to fix ODBC driver issue
' Hector Miguel Orozco Diaz for the "DeleteConnections_12" idea
'---------------------------------------------------------------------------------------
'
Sub MergeFiles()
Dim PT As PivotTable
Dim PC As PivotCache
Dim arrFiles As Variant
Dim strSheet As String
Dim strPath As String
Dim strSQL As String
Dim strCon As String
Dim rng As Range
Dim i As Long
strPath = CurDir
ChDirNet ThisWorkbook.Path
arrFiles = Application.GetOpenFilename("Excel Workbooks (*.xlsx), *.xlsx", , , , True)
strSheet = "Deliverables"
If Not IsArray(arrFiles) Then Exit Sub
Application.ScreenUpdating = False
If Val(Application.Version) > 11 Then DeleteConnections_12
Set rng = ThisWorkbook.Sheets(1).Cells
rng.Clear
For i = 1 To UBound(arrFiles)
If strSQL = "" Then
strSQL = "SELECT * FROM [" & strSheet & "$]"
Else
strSQL = strSQL & " UNION ALL SELECT * FROM `" & arrFiles(i) & "`.[" & strSheet & "$]"
End If
Next i
strCon = _
"ODBC;" & _
"DSN=Excel Files;" & _
"DBQ=" & arrFiles(1) & ";" & _
"DefaultDir=" & "" & ";" & _
"DriverId=790;" & _
"MaxBufferSize=2048;" & _
"PageTimeout=5"
Set PC = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)
With PC
.Connection = strCon
.CommandType = xlCmdSql
.CommandText = strSQL
Set PT = .CreatePivotTable(TableDestination:=rng(6, 1))
End With
With PT
With .PivotFields(1) 'Sub Category
.Orientation = xlRowField
.Position = 1
End With
.AddDataField .PivotFields(8), "DueDate", xlCount 'Action Required
With .PivotFields(1) 'Action Required
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields(1) 'Owner
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields(2) 'Status
.Orientation = xlRowField
.Position = 1
.DataRange.Cells(1).Group _
Start:=True, _
End:=True, _
Periods:=Array(False, False, False, False, True, False, False)
End With
End With
'Clean up
Set PT = Nothing
Set PC = Nothing
ChDirNet strPath
Application.ScreenUpdating = True
End Sub
Private Sub DeleteConnections_12()
' This line won't work and wouldn't be necessary
' in the versions older than 2007
'*****************************************************************************
On Error Resume Next: ThisWorkbook.Connections(1).Delete: On Error GoTo 0
'*****************************************************************************
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
When I run the script, I get to Line 92, where I get a run-time error 1004: Cannot group that selection.
.DataRange.Cells(1).Group _
Start:=True, _
End:=True, _
Periods:=Array(False, False, False, False, True, False, False)
For the life of me, I'm lost and cannot find anything anywhere to fix this.
Can anyone make any recommendations or suggestions?
I am still very new at VBA, but not with PivotTables. I am trying to avoid having to manually compile all of the data from the source workbooks into a master and running the PivotTable from there, because the workbooks are owned by three different users and are updated regularly. I am utilizing an OFFSET formula to name my source data range, and using this as my data source for my PivotTables so they all update at once, and the formula automatically increases the range to include any new rows or columns that have been added to the source data sheet.
I also recognize that just because it works up to the grouping point, that doesn't mean that the variables for the PivotFields are done correctly either - so if someone sees something there too - I'm open to hearing about it!
I am working in Excel 2013 and 2010.
Transfer from Question what appears to be an answer, or as near as likely to be achieved:
Here are screen shots of both my data set of what my pivot tables look like derived from each individual workbook's data set, and how I want it to look by running the script:
Looking at #KazJaw comments, I've researched the Range.Group and looked at the Periods portion. I ended up deleting it completely and ran the script without a problem! Have to manually adjust the Field Lists and formatting, but that's the easy part compared with pulling the actual data as it is always and ever changing.

Resources