Excel 我正在尝试将4个数据透视表的行标签一个接一个地复制到不同的工作表中_Excel_Vba_Pivot Table

Excel 我正在尝试将4个数据透视表的行标签一个接一个地复制到不同的工作表中

excel vba

Excel 我正在尝试将4个数据透视表的行标签一个接一个地复制到不同的工作表中,excel,vba,pivot-table,Excel,Vba,Pivot Table,我正在尝试将4个透视行标签数据一个接一个地复制到另一个名为“RSL to Review”的工作表中。我能够只复制一个数据透视图数据，这样就可以创建完整的数据透视图，之后就不会出现错误，也不会出现循环 Sub Macro2() Dim i As Integer Dim LR As Integer For i = 1 To 4 LR = Sheets("pivot").Range("a" & Rows.Count).End(xlUp).Row

我正在尝试将4个透视行标签数据一个接一个地复制到另一个名为“RSL to Review”的工作表中。我能够只复制一个数据透视图数据，这样就可以创建完整的数据透视图，之后就不会出现错误，也不会出现循环

Sub Macro2()
    Dim i As Integer
    Dim LR As Integer

    For i = 1 To 4
        LR = Sheets("pivot").Range("a" & Rows.Count).End(xlUp).Row

       ' Sheets("RSL to Review").Activate

        Sheets("pivot").PivotTables("PivotTable" & i).PivotSelect "", xlLabel,true 
            Selection.Copy
        Sheets("RSL to Review").Activate
            Sheets("RSL to Review").Range("b" & LR + 2).Select
            ActiveSheet.Paste
    Next i
End Sub

结果应为平台（轴行标签）

数据透视表的参数“Mode”必须是

xlLabelOnly

，而不是“xlLabel”（请参阅）

最后使用的行（“LR”）的计算必须在目标工作表上执行，并且直接在每次粘贴操作之前执行

请先试试这个：

Sub Macro2()
    Dim i As Integer
    Dim LR As Integer

    Sheets("pivot").Activate
    For i = 1 To 4
        Sheets("pivot").PivotTables("PivotTable" & i).PivotSelect "", xlLabelOnly, True
        Selection.Copy

        With Sheets("RSL to Review")
            LR = .Cells(.Rows.Count, "B").End(xlUp).Row
            .Cells(LR + 2, "B").PasteSpecial Paste:=xlPasteAll
        End With
    Next i
End Sub

您可以将

Range.PasteSpecial

参数更改为

xlpasteValues和NumberFormats

或任何需要的参数。如果粘贴

xlPasteAll

或

xlPasteAllUsingSourceTheme

则目标位置也有数据透视表（如果数据透视表相互重叠，则会出现错误）

使用

PivotSelect

复制选定范围时，必须先激活（激活）该工作表。正如每个人都在努力的那样，有一个更好的解决方案

您可以通过此复制

RowFields（）.LabelRange

或

RowFields（）.DataRange

（或通过

Union

）而无需选择或激活任何内容：

Sub CopyPivotRowlabels()
    Dim i As Long
    Dim LR As Long

    For i = 1 To 4
        With Sheets("pivot").PivotTables(i).RowFields(1)
            .DataRange.Copy
            'Union(.LabelRange, .DataRange).Copy
        End With

        With ActiveWorkbook.Sheets("RSL to Review")
            LR = .Cells(.Rows.Count, "B").End(xlUp).Row
            .Cells(LR + 2, "B").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        End With
    Next i
End Sub