VBA скопировать и вставить сводные значения и формат - PullRequest
Новая
       16

VBA скопировать и вставить сводные значения и формат

1 голос
/ 14 июня 2019

Я пытаюсь скопировать и вставить сводную таблицу, но я хочу сохранить значения и формат. 

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

1 Ответ

0 голосов
/ 14 июня 2019

Видимо, это работает только с 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
...