使用Vba通过数据透视表进行迭代，同时将单个字段复制到单独的表中

I am using Excel 2013 and I have a pivot table with hundreds of filter values that I need to iterate through, making each one visiible individually , then copy the filtered value, and a specific cell (non-Pivot, and IF >0) and paste it (values only) into a specified sheet and the move on to the next pivot item and do the same. I found some code that is similar to what I want

我正在使用Excel 2013,我有一个包含数百个过滤器值的数据透视表,我需要迭代它们,使每个过滤器值可单独显示,然后复制过滤后的值和特定单元格(非Pivot,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

End Sub However, I know I need to cut out

End Sub然而,我知道我需要削减

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

I just do not know what to add to for the copying of a certain cell (non-Pivot) and pasting it into a different sheet assuming it meets the >0 criteria. I am relatively new to VBA and I am trying to improve my skills.

我只是不知道要复制某个单元格(非Pivot)要添加什么,并将其粘贴到另一个表格中,假设它符合> 0标准。我对VBA比较陌生,我正努力提高自己的技能。

Adding Screenshots for Reference Essentially, I am wanting to iterate through B3 (Pivot Table) and copy B3 and F46 into the new sheet pictured below If F46>0. :

为参考添加屏幕截图基本上,我想迭代B3(数据透视表)并将B3和F46复制到下面的新表中如果F46> 0。 :

Thanks.

1 个解决方案

#1

This should work for you. You will need to adjust the pivot and data sheet names as marked below.

这应该适合你。您需要调整下面标记的数据透视表和数据表名称。

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