Question

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

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

Answer 1

显然，此方法仅在PivotTable.TableRange1上有效
（这是不带过滤器的数据透视表的主要范围，即上方的PageFields）
和不使用完整的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

VBA复制和粘贴透视值和格式

1 个答案: