在将单个字段复制到单独的工作表时，使用Vba迭代透视表

我正在使用Excel 2013，我有一个数据透视表，其中包含数百个需要迭代的筛选值，使每个筛选值单独可见，然后复制筛选值和特定单元格（非数据透视，如果>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

我只是不知道复制某个单元格（非轴）并将其粘贴到另一张表（假设它满足>0标准）时要添加什么。我对VBA比较陌生，我正在努力提高我的技能

添加屏幕截图以供参考 基本上，我想迭代B3（透视表），如果F46>0，则将B3和F46复制到下图所示的新表中：

---

谢谢。

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

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

Sub-PivotStockItems（）
作为整数的Dim i
以字符串形式显示
Dim pivotSht作为工作表，dataSht作为工作表
将pivotSht=Sheets（“test”）调整为包含数据透视表的工作表的名称
根据您的图像设置dataSht=图纸（“SKU和SKU节约”）
Application.ScreenUpdating=False
使用数据透视表（“数据透视表1”）
.PivotCache.MissingItemsLimit=xlMissingItemsOne
.PivotCache.Refresh
带.PivotFields（“是”）
'---隐藏除项目1以外的所有项目
.PivotItems（1）.可见=真
对于i=2到.PivotItems.Count
.PivotItems（i）.Visible=False
下一个
对于i=1到.PivotItems.Count
.PivotItems（i）.可见=真
如果i为1，则.PivotItems（i-1）.Visible=False
sItem=.PivotItems（i）
'这将考虑条件和复制粘贴
如果数据透视范围（“F46”）值>0，则
单元格（getLastFilledRow（dataSht）+1,1）.Value=sItem
单元格（getLastFilledRow（dataSht），2）.Value=pivotSht.Range（“F46”）.Value
否则：如果
接下来我
以
以
端接头
'获取给定工作表的最后填充行号
公共函数getLastFilledRow（sh作为工作表）作为整数
出错时继续下一步
getLastFilledRow=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（“A1”）_
看：=xlPart_
LookIn:=xlValues_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
错误转到0
端函数

添加透视表的屏幕截图，并添加了一个示例，说明根据您的条件过滤哪个字段，以及您需要复制的内容（使用油漆更好地描述它）屏幕截图。谢谢您的帮助。“F46”是数据透视表的一部分吗？或者只是一个单元格“骑”在数据透视表的值上被过滤？范围（“A40:I47”）是数据透视表的一部分？是要在“F46”中一直复制的单元格吗？F46与透视表是分开的。还有其他数据字段“占用”透视表数据，但是这些字段不需要复制。最终目标是有4个不同的VBA代码集，根据审查的季度将其输入4个单独的表中。F46=Q1、G46=Q2等。我应该能够编辑VBA以反映这些差异，我只需要帮助构建基本代码。再次感谢你的帮助。改用这个怎么样？这样，您就不需要对pivot表进行任何操作，只需迭代筛选值，将它们插入函数，测试返回的值以确保大于0，然后在其他工作表中输入值。要了解函数的工作原理，请转到不在透视表中的单元格，按=键，然后单击透视表值部分中的单元格并按Enter键。您将看到Excel在该单元格中输入GETPIVOTDATA工作表函数。很高兴听到这个消息！3个月后回复时，我以为我的答案是空穴来风

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