VBA将测量添加到PowerPivot数据透视表

Question

更新：我想我找到了答案，但我还没有看到在Excel 2013中是否有办法做到这一点。

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

该链接有关于ModelMeasures.Add方法的文档，但是我现在没有真正的好例子。如果有人在Excel 2013中有一个很好的示例，可以使用VBA向模型添加度量，请分享作为答案。

我能找到的最佳示例，但无法在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

---

---

---

---

原始邮寄：

我正在尝试使用VBA自动将计算字段添加到powerpivot数据透视表。我对VBA没有经验。

当我使用下面的公式手动添加计算字段时，我能够看到添加的计算字段。这个VBA代码有什么问题？

这是我的代码：

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

我得到的错误：

运行时错误'1004'：应用程序定义的错误或对象定义的错误

Answer 1

将这些黑客一起加载以从Excel工作表加载（将需要更改范围等）将覆盖现有度量的公式，因此可以迭代而不必处理错误消息（除了最后一个错误处理程序）。

最好的部分是可以不按顺序加载度量，以便可以加载依赖于另一个度量的度量。

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