vba - 使用 Vba 迭代数据透视表，同时将单个字段复制到单独的工作表中

Question

我使用的是 Excel 2013，我有一个包含数百个过滤器值的数据透视表，我需要迭代这些过滤器值，使每个值单独可见，然后复制过滤后的值和特定单元格(非数据透视表和 IF > 0)并将其粘贴(仅值)到指定的工作表中，然后移动到下一个数据透视项并执行相同的操作。 我找到了一些与我想要的类似的代码

Sub PivotStockItems()
Dim i As Integer
Dim sItem As String
Application.ScreenUpdating = False
With ActiveSheet.PivotTables("PivotTable1")
    .PivotCache.MissingItemsLimit = xlMissingItemsNone
    .PivotCache.Refresh
    With .PivotFields("Country")
        '---hide all items except item 1
        .PivotItems(1).Visible = True
        For i = 2 To .PivotItems.Count
            .PivotItems(i).Visible = False
        Next
        For i = 1 To .PivotItems.Count
            .PivotItems(i).Visible = True
            If i <> 1 Then .PivotItems(i - 1).Visible = False
            sItem = .PivotItems(i)
            Cells.Copy
            Workbooks.Add
            With ActiveWorkbook
                .Sheets(1).Cells(1).PasteSpecial _
                    Paste:=xlPasteValuesAndNumberFormats
                .SaveAs "C:\TEST\MyReport-" & sItem & ".xlsx", _
                    FileFormat:=xlOpenXMLWorkbook
                .Close
            End With
        Next i
    End With
End With

结束子 但是，我知道我需要删掉

Cells.Copy
        Workbooks.Add
        With ActiveWorkbook
            .Sheets(1).Cells(1).PasteSpecial _
                Paste:=xlPasteValuesAndNumberFormats
            .SaveAs "C:\TEST\MyReport-" & sItem & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook
            .Close

我只是不知道要添加什么来复制某个单元格(非数据透视)并将其粘贴到另一个工作表中(假设它满足 >0 标准)。我对 VBA 比较陌生，我正在努力提高我的技能。

添加屏幕截图以供引用 本质上，我想迭代 B3(数据透视表)并将 B3 和 F46 复制到下图所示的新工作表中(如果 F46>0)。 :

谢谢。

Answer 1

这应该适合你。您将需要调整数据透视表和数据表名称，如下所示。

Sub PivotStockItems()
    Dim i As Integer
    Dim sItem As String
    Dim pivotSht As Worksheet, dataSht As Worksheet

    Set pivotSht = Sheets("test") 'adjust to the name of sheet containing your pivot table
    Set dataSht = Sheets("SKUS_With_Savings") 'as per your image

    Application.ScreenUpdating = False
    With pivotSht.PivotTables("PivotTable1")
        .PivotCache.MissingItemsLimit = xlMissingItemsNone
        .PivotCache.Refresh
        With .PivotFields("Yes")
            '---hide all items except item 1
            .PivotItems(1).Visible = True
            For i = 2 To .PivotItems.Count
                .PivotItems(i).Visible = False
            Next
            For i = 1 To .PivotItems.Count
                .PivotItems(i).Visible = True
                If i <> 1 Then .PivotItems(i - 1).Visible = False
                sItem = .PivotItems(i)

                'this takes care of the condition and copy-pasting
                If pivotSht.Range("F46").Value > 0 Then
                    dataSht.Cells(getLastFilledRow(dataSht) + 1, 1).Value = sItem
                    dataSht.Cells(getLastFilledRow(dataSht), 2).Value = pivotSht.Range("F46").Value
                Else: End If

            Next i
        End With
    End With
End Sub

'gets last filled row number of the given worksheet
Public Function getLastFilledRow(sh As Worksheet) As Integer
    On Error Resume Next
    getLastFilledRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function