Convert pivot table to sumif function - Error 424 - Excel VBA - excel

Question

I would like to convert a Pivot Table to a sum if statement using a VBA macro.
I found one which used to work on Excel 2016 (https://www.excelcampus.com/vba/convert-pivot-table-to-sumifs-formulas-vba-macro/) since I went to 0365, the macro is not working.
I tried to fix the code myself but got stuck on the line
Set rSource = Application.Evaluate(Application.ConvertFormula(PivotTable.SourceData, xlR1C1, xlA1))
which led to a #424 error object needed.
Any ideas would be gratefully accepted!
The whole code is the following`and the error seems to come from the function part:
Option Explicit
Dim pvt As PivotTable
Dim rSource As Range
Dim wsSource As Worksheet
Dim bTable As Boolean
Dim pi As PivotItem
Dim pc As PivotCell
Dim pf As PivotField
Dim wsNew As Worksheet
Dim wsPivot As Worksheet
Dim c As Range
Dim lFunction As Long
Dim sSumRange As String
Dim sCritRange As String
Dim sCriteria As String
Dim sFormula As String
Dim sFormulaPage As String
Dim sSearchField As String
Dim sDataSheet As String
Dim lDataRows As Long
Dim sPageRange As String
Dim lCol As Long
Dim bArray As Boolean
Dim sTableName As String
Dim sFormulaArgs As String
Dim sFormulaCnt As String
Dim lLblRow As Long
Dim lLblCol As Long
Dim sFilter As String
Dim sDataField As String
Dim bReturn As Boolean
Sub Convert_Pivot_to_Formulas()
'---------------------------------------------------------------------------------------
' Procedure : Convert_Pivot_to_Formulas
' Author : Jon Acampora, Excel Campus LLC, www.excelcampus.com
' Date : 10/13/2014
' Purpose : Creates a copy of the selected pivot table on a new sheet and converts
' all cells in the values area to SUMIFS, COUNTIFS, or AVERAGEIFS formulas
' Details : The following is a list of features, requirement, and limitations of the macro.
' Features
' - Works with page fields with multiple items in filter of one page field.
' Creates the page field criteria across columns and creates array formulas.
' Requirements
' - Fields in the pivot containing dates must be in the same format as the source data.
' - Source data must be in same workbook. This can be expaned to ref source data in other workbooks.
' Limitations
' - Does not work with grouped date fields. The criteria ranges do NOT exist in the source data.
' Create the date group fields as columns in the source data to solve this issue.
'---------------------------------------------------------------------------------------
'Set pivot table variables
On Error Resume Next
Set pvt = ActiveCell.PivotTable
Set wsPivot = ActiveSheet
On Error GoTo 0
If pvt Is Nothing Then
MsgBox "Please select a Pivot Table first.", vbOKOnly, "Convert Pivot to Formula Error"
Exit Sub
End If
'Check if source data is in the same workbook.
If Get_Pivot_Source Then
On Error GoTo Err_Handle
'-------------------------------------------------------
'1. Create new sheet with shell of pivot table - filter, rows, columns areas
'-------------------------------------------------------
Set wsNew = Worksheets.Add(after:=ActiveSheet)
sDataSheet = wsSource.Name
lDataRows = rSource.Rows.Count
If bTable Then sTableName = pvt.SourceData
'Copy pivot table values to new sheet
wsPivot.Select
wsPivot.Range(pvt.TableRange1.Address).Copy
With wsNew.Range(pvt.TableRange1.Address)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
If pvt.PageFields.Count > 0 Then
wsPivot.Range(pvt.PageRange.Address).Copy
With wsNew.Range(pvt.PageRange.Address)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
End If
'-------------------------------------------------------
'2. Add page field filters across columns in new sheet
'-------------------------------------------------------
If pvt.PageFields.Count > 0 Then
For Each pf In pvt.PageFields
sPageRange = pf.LabelRange.Offset(, 1).Resize(1, 1).Address
sFilter = pf.LabelRange.Offset(, 1).Resize(1, 1).Value
lCol = 0 'offset 1 col to the right
Select Case sFilter
Case "(All)"
'skip
Case "(Multiple Items)"
'Loop pivot items and add selected items to page range across columns
For Each pi In pf.PivotItems
If pi.Visible Then
wsNew.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value = pi.Name
lCol = lCol + 1
End If
Next pi
Case Else 'One item selected
lCol = 1
wsPivot.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value = wsNew.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value
End Select
'Create string for formula
If lCol > 0 Then 'filters exist
If bTable Then
sCritRange = sTableName & "[" & pf.Name & "]"
Else
sSearchField = pf.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
sCriteria = wsNew.Range(sPageRange).Resize(1, lCol).Address
sFormulaPage = sFormulaPage & "," & sCritRange
sFormulaPage = sFormulaPage & "," & sCriteria
End If
'IFS formula will have to be an array if there are multiple critera (range) in criteria argument
If lCol > 1 Then bArray = True
Next pf
End If
'-------------------------------------------------------
'3. Loop through each cell in values area to build formula.
'-------------------------------------------------------
For Each c In pvt.DataBodyRange.Cells
Set pc = c.PivotCell
sFormula = ""
sFormulaArgs = ""
'-------------------------------------------------------
'4. Create SUM RANGE reference for formula
'-------------------------------------------------------
'Check if function is sum, count, or average
If pc.PivotField.Function = xlSum Or pc.PivotField.Function = xlCount Or pc.PivotField.Function = xlAverage Then
'Count the criteria, if 0 then it's a total and no IFS needed
sCriteria = ""
'Add column items to filter array
If pc.PivotCellType = xlPivotCellValue Then
sDataField = pc.PivotField.SourceName
lFunction = pc.PivotField.Function
'Add Sum Range
lFunction = pc.PivotField.Function
If bTable Then
sSumRange = sTableName & "[" & pc.PivotField.SourceName & "]"
Else
sSearchField = pc.PivotField.SourceName
sSumRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
'-------------------------------------------------------
'5. Loop through ROW items of pivotcell and add row refs to formula
'-------------------------------------------------------
If pc.RowItems.Count Then
For Each pi In pc.RowItems
If bTable Then
sCritRange = sTableName & "[" & pi.Parent.Name & "]"
Else
sSearchField = pi.Parent.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
'Find the address of the pivotcells labelrange for the criteria address
'Start from the current row and loop up through the label range until the
'pivotitem name is found. Required due to variety of pivot table layouts.
lLblCol = pi.LabelRange.Column
For lLblRow = c.Row To pi.Parent.LabelRange.Row + 1 Step -1
If Cells(lLblRow, lLblCol).Value = pi.Name Then
sCriteria = Cells(lLblRow, pi.LabelRange.Column).Address
Exit For
End If
Next lLblRow
If sCriteria <> "" Then
sFormulaArgs = sFormulaArgs & "," & sCritRange
sFormulaArgs = sFormulaArgs & "," & sCriteria
End If
sCriteria = ""
Next pi
End If
'-------------------------------------------------------
'6. Loop through COLUMN items of pivotcell and add row refs to formula
'-------------------------------------------------------
If pc.ColumnItems.Count Then
For Each pi In pc.ColumnItems
If bTable Then
sCritRange = sTableName & "[" & pi.Parent.Name & "]"
Else
sSearchField = pi.Parent.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
' If sCritRange Is Nothing Then
' On Error GoTo 0
' Else
' End If
End If
'Find the address of the pivotcells labelrange for the criteria address
'Start from the current column and loop back left through the label range until the
'pivotitem name is found. Required due to variety of pivot table layouts.
lLblRow = pi.LabelRange.Row
For lLblCol = c.Column To pi.LabelRange.Column Step -1
If Cells(lLblRow, lLblCol).Value = pi.Name Then
sCriteria = Cells(pi.LabelRange.Row, lLblCol).Address
Exit For
End If
Next lLblCol
If sCriteria <> "" Then
sFormulaArgs = sFormulaArgs & "," & sCritRange
sFormulaArgs = sFormulaArgs & "," & sCriteria
End If
sCriteria = ""
Next pi
End If
'-------------------------------------------------------
'7. Build Formula based on function type of pivotcell
'-------------------------------------------------------
Select Case pc.PivotField.Function
Case xlSum
If sFormulaArgs = "" And sFormulaPage = "" Then 'Don't need IFS when there are no criteria (total rows/columns)
sFormula = "=SUM(" & sSumRange & ")"
Else
If bArray Then
sFormula = "=SUM(SUMIFS(" & sSumRange & sFormulaPage & sFormulaArgs & "))"
Else
sFormula = "=SUMIFS(" & sSumRange & sFormulaPage & sFormulaArgs & ")"
End If
End If
Case xlCount
If sFormulaArgs = "" And sFormulaPage = "" Then 'Don't need IFS when there are no criteria (total rows/columns)
sFormula = "=COUNT(" & sSumRange & ")"
Else
sFormulaCnt = sFormulaPage & sFormulaArgs 'Don't need sum range for countifs
sFormulaCnt = Right(sFormulaCnt, Len(sFormulaCnt) - 1) 'trim preceding comma
If bArray Then
sFormula = "=SUM(COUNTIFS(" & sFormulaCnt & "))"
Else
sFormula = "=COUNTIFS(" & sFormulaCnt & ")"
End If
End If
Case xlAverage
If sFormulaArgs = "" And sFormulaPage = "" Then 'Don't need IFS when there are no criteria (total rows/columns)
sFormula = "=AVERAGE(" & sSumRange & ")"
Else
sFormula = "=AVERAGEIFS(" & sSumRange & sFormulaPage & sFormulaArgs & ")" 'AVERAGEIFS not working with array formula, returns errors
End If
End Select
'-------------------------------------------------------
'8. Add formula to new sheet
'-------------------------------------------------------
If bArray Then
If Len(sFormula) < 255 Then
wsNew.Range(c.Address).FormulaArray = sFormula
Else
'.FormulaArray hits an error if formula string is > 255 characters
'Add error handling here
End If
Else
wsNew.Range(c.Address).Formula = sFormula
End If
End If
End If
Next c
End If
wsNew.Select
Exit Sub
Err_Handle:
MsgBox Err.Description & vbNewLine & "Current Cell: " & c.Address, _
vbCritical, "Convert Pivot to Formulas Error"
End Sub
Function Get_Pivot_Source() As Boolean
'Determine if source is a cell reference, named range, or Excel Table
'Set source range variables
'Consider using the PivotCache.SourceType property to check this.
'http://msdn.microsoft.com/en-us/library/office/ff194557.aspx
'On Error GoTo Err_Handler
'Set variables for selected pivot table
bReturn = False
Set rSource = Nothing
Set wsSource = Nothing
Set pvt = ActiveCell.PivotTable
Set wsPivot = ActiveSheet
bTable = False
If ActiveCell.PivotTable.PivotCache.SourceType = xlDatabase Then
If InStr(ActiveCell.PivotTable.SourceData, "[") = 0 Then 'check if source data contains workbook name - bypass external source range - Temp TO DO
If InStr(ActiveCell.PivotTable.SourceData, ":") > 0 Then 'if data source range is a cell ref range
Set rSource = Application.Evaluate(Application.ConvertFormula(ActiveCell.PivotTable.SourceData, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1))
Else 'if Table or Named Range are used as data source range
Set rSource = Range(pvt.SourceData)
On Error GoTo SkipTable 'check if the data source name is a table
Set rSource = Range(pvt.SourceData & "[#All]")
bTable = True
SkipTable:
On Error GoTo 0
End If
Set wsSource = rSource.Parent
bReturn = True
End If
End If
Get_Pivot_Source = bReturn
Exit Function
Err_Handler:
MsgBox "Error in Get_Source_Range procedure."
Get_Pivot_Source = False
End Function