数据透视表的 Excel 宏

Question

所以我创建了一个宏来在 excel 中创建一个基本的数据透视表。我录制了宏并有 5 个过滤器。运行宏时，格式变得混乱，过滤器跨列列出，而不是垂直列出。如何让过滤器垂直列出？ Incorrect Format Image Correct Format Image

    Range("Table1[[#Headers],[Installation]]").Select
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Table1", Version:=6).CreatePivotTable TableDestination:="Sheet1!R3C1", _
        TableName:="PivotTable1", DefaultVersion:=6
    Sheets("Sheet1").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1")
        .ColumnGrand = True
        .HasAutoFormat = True
        .DisplayErrorString = False
        .DisplayNullString = True
        .EnableDrilldown = True
        .ErrorString = ""
        .MergeLabels = False
        .NullString = ""
        .PageFieldOrder = 2
        .PageFieldWrapCount = 0
        .PreserveFormatting = True
        .RowGrand = True
        .SaveData = True
        .PrintTitles = False
        .RepeatItemsOnEachPrintedPage = True
        .TotalsAnnotation = False
        .CompactRowIndent = 1
        .InGridDropZones = False
        .DisplayFieldCaptions = True
        .DisplayMemberPropertyTooltips = False
        .DisplayContextTooltips = True
        .ShowDrillIndicators = True
        .PrintDrillIndicators = False
        .AllowMultipleFilters = False
        .SortUsingCustomLists = True
        .FieldListSortAscending = False
        .ShowValuesRow = False
        .CalculatedMembersInFilters = False
        .RowAxisLayout xlCompactRow
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotCache
        .RefreshOnFileOpen = False
        .MissingItemsLimit = xlMissingItemsDefault
    End With
    ActiveSheet.PivotTables("PivotTable1").RepeatAllLabels xlRepeatLabels
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
        "Accountable" & Chr(10) & "Organization")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
        "Installation/Site/Proponent Submittal")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("SRP")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("New Submitter")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
        "Submittal Data Received")
        .Orientation = xlPageField
        .Position = 1
    End With

Answer 1

我不知道您是否有一个实际的 Excel 表格作为源。如果你这样做了，你可以执行如下操作（检查字段名称拼写，我还假设行字段称为 Base）

Option Explicit

Public Sub CreatePivotFromTable()

    Dim table As ListObject
    Set table = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")

    '    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$R$16"), , xlYes).Name = _
    '        "Table1"  ''<======== code for creating table instead if not already present

    Sheets.Add

    With ActiveSheet

        Dim pvt As PivotTable

        ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
                                        table, Version:=6).CreatePivotTable TableDestination:=.Range("A3"), _
                                        TableName:="PivotTable1", DefaultVersion:=6 'version 6 information may need removing

        Set pvt = .PivotTables("PivotTable1")

        Dim pvtPageFieldArr()
        ''Note check spellings of fields below and base is an placeholder name for the field containing Ten Nat Guard etc
        pvtPageFieldArr = Array("Accountable Organisation", "Installation/Proponent Submittal", "SRP", "New Submitter", _
                                "Submittal Data Received", "Base")

        Dim fieldName As Long

        For fieldName = LBound(pvtPageFieldArr) To UBound(pvtPageFieldArr)

            With pvt.PivotFields(pvtPageFieldArr(fieldName))
                .Orientation = xlPageField
                .Position = 1
            End With

        Next fieldName

        Dim pvtRowFieldArr()
        ''Note check spellings of fields below and base is an placeholder name for the field containing Ten Nat Guard etc
        pvtRowFieldArr = Array("Base")

        For fieldName = LBound(pvtRowFieldArr) To UBound(pvtRowFieldArr)

            With pvt.PivotFields(pvtRowFieldArr(fieldName))
                .Orientation = xlRowField
                .Position = 1
            End With

        Next fieldName

        Dim dataFieldArr()

        dataFieldArr = Array("Layers Submitted", "New Schema-Compliant Layers", "Schema-Compliant Layers with changes", _
                             "Schema-Compliant Layers with NO changes", "Empty. Non Compliant. Non-SRP Proponent Submitted by SRP", _
                             "Layers in Repository", "Repository Layers Checked for QAP Compliance", "# of Repository Layers Checked for QAP Compliance", _
                             "Total # of QAP Checks Performed", "Total # of QAP Errors Found", "Roll-Up QAP Compliance Total % Accuracy")

        Dim currField As String

        For fieldName = LBound(dataFieldArr) To UBound(dataFieldArr)

            currField = dataFieldArr(fieldName)
            pvt.AddDataField pvt.PivotFields(currField), "Sum of " & currField, xlSum

        Next fieldName

    End With

End Sub

这是Sheet 1具有表格（选择范围内的填充单元时，用Ctrl + T创建表）

）

表格 1 输入：

新工作表输出：