VBA 复制并粘贴枢轴值和格式

我尝试复制并粘贴数据透视表，但我想保留值和格式。

Sub PivotTablePaste()

    Set pt = Worksheets("Sheet1").PivotTables(1)
    pt.TableRange2.Copy

    With Worksheets("Sheet1").Range("P1")

        .PasteSpecial Paste:=xlPasteValues

        .PasteSpecial Paste:=xlPasteFormats

        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

    End With

End Sub

显然这有效only with PivotTable.TableRange1
（这是没有过滤器的数据透视表的主要范围，即PageFields它上面）
and not与完整的PivotTable.TableRange2.

如果您的数据透视表也有页面字段，那么您必须另外逐个单元格地复制数据透视表上方的该范围。

Sub PivotTablePaste()
    Dim SourcePivottable As PivotTable
    Dim DestinationRange As Range
    Dim aCell As Range

    Set SourcePivottable = Worksheets("Sheet1").PivotTables(1)
    Set DestinationRange = Worksheets("Sheet1").Range("P1")

    ' Copy TableRange1
    SourcePivottable.TableRange1.Copy
    With DestinationRange.Offset( _
      SourcePivottable.TableRange1.Row - SourcePivottable.TableRange2.Row, 0)
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With

    ' Copy everything above TableRange1 cell-by-cell
    For Each aCell In SourcePivottable.TableRange2.Cells
        If Not Intersect(aCell, SourcePivottable.TableRange1) Is Nothing Then Exit For
        aCell.Copy
        With DestinationRange.Offset( _
          aCell.Row - SourcePivottable.TableRange2.Row, _
          aCell.Column - SourcePivottable.TableRange2.Column)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
        End With
    Next aCell

End Sub