Блог

Я пытаюсь создать сводную таблицу на новом листе. Кроме того, я хотел бы создать еще один вызов для создания другой сводной таблицы, используя те же данные из первой таблицы данных.

возникли проблемы с приведенным ниже макрокомандой. Я думаю, что это небольшая ошибка, но не могу ее понять.

 Sub Macro2()

    Dim FinalRow            As Long
    Dim DataSheet           As String
    Dim PvtCache            As PivotCache
    Dim PvtTbl              As PivotTable
    Dim DataRng             As Range
    Dim TableDest           As Range
    Dim ws                  As Worksheet

    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    DataSheet = ActiveSheet.Name

    'set data range for Pivot Table -- ' conversion of R1C1:R amp; FinalRow amp; C15
     Set DataRng = Sheets(DataSheet).Range(Cells(1, 1), Cells(FinalRow, 15)) 

    Set ws = Worksheets.Add
    ws.Name = "Travel Payment Data by Employee"

    'set range for Pivot table placement -- Conversion of R1C1
    Set TableDest = Sheets("Travel Payment Data by Employee").Cells(1, 1)

    Set PvtCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, DataRng, xlPivotTableVersion15)

    'check if "PivotTable4" Pivot Table already created (in past runs of this Macro)
    Set PvtTbl = ActiveWorkbook.Sheets("Travel Payment Data by Employee").PivotTables("PivotTable4")

    With PvtTbl.PivotFields("Security Org")
        .Orientation = xlRowField
        .Position = 1
    End With
    With PvtTbl.PivotFields("Fiscal Month")
        .Orientation = xlRowField
        .Position = 2
    End With
    With PvtTbl.PivotFields("Budget Org")
        .Orientation = xlRowField
        .Position = 3
    End With
    With PvtTbl.PivotFields("Vendor Name")
        .Orientation = xlRowField
        .Position = 4
    End With
    With PvtTbl.PivotFields("Fiscal Year")
        .Orientation = xlRowField
        .Position = 5
    End With
    With PvtTbl.PivotFields("Fiscal Year")
        .Orientation = xlColumnField
        .Position = 1
    End With
    PvtTbl.AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Dollar Amount"), "Sum of Dollar Amount", xlSum

End Sub
  

Рассмотрите следующую настройку с помощью подпрограммы, вызывающей функцию, передающую новые имена рабочих листов для новых идентичных сводных таблиц. Если вы не собираетесь использовать идентичные сводные таблицы, настройте их в коде условно по имени листа или копии функции. Основные изменения в вашем коде заключаются в следующем:

1. АКТИВНЫЙ ЛИСТ: устраните необходимость поиска ActiveSheet.Name , поскольку добавление дополнительных листов приведет к изменению активных листов. Просто запрограммируйте или передайте в качестве параметра источник данных.
2. ПРОВЕРКА ОБЪЕКТА: необходимо проверить, существует ли выход из рабочего листа и сводная таблица. Для этого вам нужно будет перебрать все текущие такие объекты и условно установить worksheet, объекты сводной таблицы (см. For...Next Циклы и If ... Is Nothing проверки).
3. Для сводного поля, поскольку суммы в долларах будут существовать в источнике данных сводной таблицы, но не обязательно отображаться, перебор всех из них может работать не так, как указано выше. Так что условно добавляйте только в том случае, если не выдает ошибку, см. On Resume Next Дескриптор.

VBA

 Option Explicit

Public Sub RunPivots()
    Call BuildPivot("Travel Payment Data by Employee")
    Call BuildPivot("Other Worksheet")
    Call BuildPivot("Still More Worksheet")
End Sub

Function BuildPivot(paramSheet As String)
On Error GoTo ErrHandle
    Dim FinalRow            As Long
    Dim DataSheet           As String
    Dim PvtCache            As PivotCache
    Dim PvtTbl              As PivotTable
    Dim PvtFld              As PivotField
    Dim DataRng             As Range
    Dim TableDest           As Range
    Dim ws                  As Worksheet

    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row

    DataSheet = "DataSourceWorksheet"    
    ' set data range for Pivot Table
     Set DataRng = Sheets(DataSheet).Range(Cells(1, 1), Cells(FinalRow, 15))

    ' check if worksheet exists
    Dim currws As Worksheet
    For Each currws In ActiveWorkbook.Worksheets
        If currws.Name = paramSheet Then
            Set ws = Worksheets(paramSheet)
            Exit For
        End If
    Next currws

    ' create new worksheet if does not exist
    If ws Is Nothing Then
        Set ws = Worksheets.Add
        ws.Name = paramSheet
    End If

    ' set range for Pivot table placement
    Set TableDest = Sheets(paramSheet).Cells(1, 1)

    ' create pivot cache
    Set PvtCache = ActiveWorkbook.PivotCaches.Create( _
              SourceType:=xlDatabase, _
              SourceData:=DataRng, _
              Version:=xlPivotTableVersion15)

    'check if "PivotTable4" Pivot Table exists            
    Dim currpvt As PivotTable
    For Each currpvt In ws.PivotTables
        If currpvt.Name = "PivotTable4" Then
            Set PvtTbl = ws.PivotTables("PivotTable4")
            Exit For   
        End If
    Next currpvt

    ' create new pivot table if does not exist
    If PvtTbl Is Nothing Then
        Set PvtTbl = PvtCache.CreatePivotTable( _
            TableDestination:=TableDest, _
            TableName:="PivotTable4")
    End If

    With PvtTbl.PivotFields("Security Org")
        .Orientation = xlRowField
        .Position = 1
    End With
    With PvtTbl.PivotFields("Fiscal Month")
        .Orientation = xlRowField
        .Position = 2
    End With
    With PvtTbl.PivotFields("Budget Org")
        .Orientation = xlRowField
        .Position = 3
    End With
    With PvtTbl.PivotFields("Vendor Name")
        .Orientation = xlRowField
        .Position = 4
    End With
    With PvtTbl.PivotFields("Fiscal Year")
        .Orientation = xlRowField
        .Position = 5
    End With
    With PvtTbl.PivotFields("Fiscal Year")
        .Orientation = xlColumnField
        .Position = 1
    End With

    ' Add data field if does not exist
    On Error Resume Next
    PvtTbl.AddDataField PvtTbl.PivotFields("Dollar Amount"), "Sum of Dollar Amount", xlSum

    Exit Function

ErrHandle:
    MsgBox Err.Number amp; " - " amp; Err.Description, vbCritical, "RUNTIME ERROR"
    Exit Function
End Function