在数据透视表中创建数据模型

Question

下面的代码可以工作，但不幸的是它没有给出正确的结果。我需要数据模型数据透视表，而不是它显示正常的数据透视表。

Sub CreateTwoDataModelPivotTablesInSameSheet()
    
        ' Set worksheets
        Dim wsSummary As Worksheet
        Dim wsProcessedData As Worksheet
        Set wsSummary = ThisWorkbook.Sheets("Summary")
        Set wsProcessedData = ThisWorkbook.Sheets("Processed Data")
    
        ' Refresh data used in pivot tables (optional)
        ' wsProcessedData.UsedRange.Refresh
    
        ' Clear existing PivotTables
        On Error Resume Next
        wsSummary.PivotTables.ClearAll
        On Error GoTo 0
    
        ' Enable Data Model for the entire workbook
        ThisWorkbook.Model.Initialize
    
        ' Create PivotCache objects
        Dim pc1 As PivotCache, pc2 As PivotCache
        Set pc1 = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=wsProcessedData.UsedRange)
        Set pc2 = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=wsProcessedData.UsedRange)
    
        ' Calculate starting row for the second table
        Dim lastRow As Long
        lastRow = wsSummary.Cells(wsSummary.Rows.Count, 2).End(xlUp).Row + 10
    
        ' Create first PivotTable
        Dim pt1 As PivotTable
        Set pt1 = pc1.CreatePivotTable(TableDestination:=wsSummary.Cells(60, 2), TableName:="PivotTable1")
    
        ' Set PivotTable1 fields and configurations
        With pt1.PivotFields("Preparer")
            .Orientation = xlPageField
        End With
     
        With pt1.PivotFields("Reviewer")
            .Orientation = xlPageField
        End With
        
        With pt1.PivotFields("Year & Month")
            .Orientation = xlPageField
        End With
        
        With pt1.PivotFields("Error Rate")
            .Orientation = xlPageField
        End With
        
        With pt1.PivotFields("Major Error")
            .Orientation = xlRowField
            .Name = "Major Error"
        End With
        
        With pt1.PivotFields("Check Number")
            .Orientation = xlDataField
            .Function = xlCount
            .Function = xlDistinctCount
            .Calculation = xlPercentOfColumn ' Use xlDistinctCount to get the distinct count
        .NumberFormat = "0%"  ' Display as a percentage
            .Name = "%"
        End With
        ' ... (other field settings)
    
        With pt1.PivotFields("Check Number")
            .Orientation = xlDataField
            .Function = xlCount
            .Calculation = xlPercentOfColumn
            .NumberFormat = "0%"
            .Name = "% of Check Number"
        End With
    
        ' Set style and refresh
        pt1.TableStyle2 = "PivotStyleDark10"
        pt1.RefreshTable
    
        ' Manually add PivotTable1 to Data Model
        pt1.CacheIndex = ThisWorkbook.Model.DataModel.Tables.Count + 1
    
        ' Create second PivotTable
        Dim pt2 As PivotTable
        Set pt2 = pc2.CreatePivotTable(TableDestination:=wsSummary.Rows(lastRow + 1).Offset(-1, 4), TableName:="PivotTable2")
    
        ' Set PivotTable2 fields and configurations
        With pt2.PivotFields("Preparer")
            .Orientation = xlPageField
        End With
    
        ' ... (other field settings)
    
        With pt2.PivotFields("Check Number")
            .Orientation = xlDataField
            .Function = xlCount
            .Calculation = xlPercentOfColumn
            .NumberFormat = "0%"
            .Name = "% of Check Number"
        End With
    
        ' Set style and refresh
        pt2.TableStyle2 = "PivotStyleLight16"
        pt2.RefreshTable
    
        ' Manually add PivotTable2 to Data Model
        pt2.CacheIndex = ThisWorkbook.Model.DataModel.Tables.Count + 1
    
        ' Set column widths (optional)
        wsSummary.Range("B:C").EntireColumn.ColumnWidth = 20
        wsSummary.Range("F:G").EntireColumn.ColumnWidth = 20
    End Sub

它正在创建普通的数据透视表而不是数据模型数据透视表，有人可以帮忙吗？我已经尝试了一个多月了，现在找不到正确的解决方案。 有什么办法可以解决这个问题或替代解决方案吗？

Answer 1

源数据在

Table1

（ListObject）

创建 PowerPivot 的步骤

• 添加查询
• 添加连接
• 添加 PowerPivot 表
• 更新 PowerPivot 布局

Option Explicit

Sub CreatePPT()
    Dim objPP As PivotTable, sForm As String
    Dim sDataFld As String, sConn As String
    Const QUERY_NAME = "QueryTable1"
    Const TABLE_NAME = "Table1"
    ' Add Query
    sForm = "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.CurrentWorkbook(){[Name=""@@""]}[Content]," _
        & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Source,{{""Name"", type text}, " & _
        "{""Sales"", type number}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    ActiveWorkbook.Queries.Add Name:=TABLE_NAME, Formula:=Replace(sForm, "@@", TABLE_NAME)
    ' Add Connection
    sConn = "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=@@;Extended Properties="
    ActiveWorkbook.Connections.Add2 _
            Name:=QUERY_NAME, _
            Description:="Connection to the table query in the workbook.", _
            ConnectionString:=Replace(sConn, "@@", TABLE_NAME), _
            CommandText:="""" & TABLE_NAME & """", _
            lCmdtype:=6, _
            CreateModelConnection:=True, _
            ImportRelationships:=False
   ' Add PowerPivot
    Set objPP = ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:= _
            ActiveWorkbook.Connections(QUERY_NAME)).CreatePivotTable(TableDestination:=Range("D1"))
    With objPP.CubeFields("[" & TABLE_NAME & "].[Name]")
        .Orientation = xlRowField
        .Position = 1
    End With
    sDataFld = "Sum of Sales"
    objPP.CubeFields.GetMeasure "[" & TABLE_NAME & "].[Sales]", xlSum, sDataFld
    objPP.AddDataField objPP.CubeFields("[Measures].[" & sDataFld & "]"), sDataFld
End Sub

样本数据

A 栏	B 栏
姓名	销售
A1	1
A2	2
A3	3
A1	4
A2	5
A3	6
A1	7
A2	8
A3	9
A1	10