VBA to Add Measure to PowerPivot Pivot Table

Question

UPDATE: I think I found the answer but I have not been able to see if there is a way to do this in Excel 2013.

https://msdn.microsoft.com/en-us/library/office/mt574976.aspx

That link has documentation on ModelMeasures.Add Method but there are no real great examples I can find out there right now. If anyone has a good example that works in Excel 2013 to add a measure to a model using VBA, please share as the answer.

Best Example I could find, but not able to accomplish in Excel 2013: https://social.msdn.microsoft.com/Forums/en-US/c7d5f69d-b8e3-4823-bbde-61253b64b80e/vba-powerpivot-object-model-adding-measures-with-modelmeasuresadd?forum=isvvba

---

---

---

---

ORIGINAL POST:

I am trying to automate the adding of calculated fields to a powerpivot pivot table using VBA. I am not experienced in VBA.

When I manually add a Calculated Field using the below formula I am able to see the Calculated Field added. What is wrong with this VBA code?

Here is my code:

Sub Macro5()
Dim PvtTbl As PivotTable
Set PvtTbl = Worksheets("Sheet4").PivotTables("PivotTable6")

'Table1 is part of the PowerPivot data model and I have created a pivot table from Table1
PvtTbl.CalculatedFields.Add "column", "=IF(HASONEVALUE(Table1[TEXT1]), VALUES(Table1[TEXT1]), BLANK())"

'Selecting the pivot table and adding the new calculated field
    Range("D7").Select
    ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
        "PivotTable6").CubeFields("[Measures].[column]")
End Sub

The Error I get:

Run-time error '1004': Application-defined or object-defined error

Answer 1

Hacked this together to load from an Excel worksheet (will need to change ranges etc) Will overwrite existing measure's formula so can iterate through and not have to deal with error messages (apart from last with the error handler).

Best part is that can load measure out of sequence so that a measure that depends on another measure can be loaded.

Sub AddMeasures()
Dim Mdl As Model
Dim tbl As ModelTable
Set Mdl = ActiveWorkbook.Model
Set tbl = Mdl.ModelTables(1)
Dim rng As Range
Set rng = Worksheets("Sheet2").Range("A2:A75")

Dim measure_name As String
Dim measure_formula As String

Dim cell As Range
Dim item As Integer

For Each cell In rng
    measure_name = cell.Value
    measure_formula = cell.Offset(0, 1).Value
    item = GetItemNumber(measure_name)
    If item > 0 Then
        Mdl.ModelMeasures.item(item).formula = measure_formula  'replace the existing formula
    Else
        On Error GoTo errhandler
        If cell.Offset(0, 2).Value = 1 Then
            Mdl.ModelMeasures.Add measure_name, tbl, measure_formula, Mdl.ModelFormatWholeNumber(1)
        Else
            Mdl.ModelMeasures.Add measure_name, tbl, measure_formula, Mdl.ModelFormatPercentageNumber(False, 1)
        End If
    End If
Next cell

errhandler:
    Debug.Print cell.Address, "Now we have a real problem"
End Sub

Function GetItemNumber(measure_name As String) As Integer
Dim cnt As Integer
Dim Mdl As Model
Dim tbl As ModelTable
Set Mdl = ActiveWorkbook.Model
Set tbl = Mdl.ModelTables(1)

For cnt = 1 To Mdl.ModelMeasures.Count
    If Mdl.ModelMeasures.item(cnt).Name = measure_name Then
        Debug.Print "Have a duplicate measure name"
        Exit For
    End If
Next cnt

If cnt > 0 And cnt <= Mdl.ModelMeasures.Count Then
    GetItemNumber = cnt
Else
    GetItemNumber = 0
End If
End Function