我来帮你搞定这个自动遍历切片器并批量复制数据的需求，结合你现有的代码，我调整出了一套完整的解决方案，还优化了原代码里依赖Select的冗余操作（直接操作单元格范围会让代码运行更快更稳定）。

完整VBA代码 #

Private Sub CommandButton1_Click()
    Dim slicerObj As Slicer
    Dim slicerItem As SlicerItem
    Dim sourceRange As Range
    Dim targetRow As Long
    
    ' 替换成你的切片器缓存名称，比如"切片器_产品类别"
    Set slicerObj = ThisWorkbook.SlicerCaches("Slicer_你的切片器名称").Slicers(1)
    
    ' 遍历切片器的每一项
    For Each slicerItem In slicerObj.SlicerCache.SlicerItems
        ' 先清除所有切片器项的选中状态，确保每次只筛选当前项
        slicerObj.SlicerCache.ClearManualFilter
        
        ' 选中当前切片器项
        slicerItem.Selected = True
        
        ' 获取Sheet1中需要复制的范围（从E3:F3延伸到最后一行有数据的行）
        With Sheets("Sheet1")
            Set sourceRange = .Range(.Range("E3:F3"), .Range("E3").End(xlDown))
        End With
        
        ' 定位Sheet2的下一个空白行
        targetRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
        
        ' 直接复制值到目标位置（替代Copy/Paste，更高效稳定）
        Sheets("Sheet2").Range("A" & targetRow).Resize(sourceRange.Rows.Count, sourceRange.Columns.Count).Value = sourceRange.Value
    Next slicerItem
    
    ' 操作完成后清除切片器选中状态，恢复初始状态
    slicerObj.SlicerCache.ClearManualFilter
    MsgBox "所有切片器项的数据已复制完成！", vbInformation
End Sub

关键说明 #

• 切片器名称替换：你需要把代码里的"Slicer_你的切片器名称"换成实际的切片器缓存名称。可以通过Excel「开发工具」→「查看代码」，在对象浏览器里找到对应切片器的缓存名称（通常以Slicer_开头，后面跟着你的字段名）。
• 避免Select操作：原代码里的Select和PasteSpecial被替换成直接赋值单元格值的方式，既减少了Excel界面的交互卡顿，也避免了因工作表切换导致的运行错误。
• 遍历逻辑：每次循环先清空所有选中项，再单独选中当前项，保证每次筛选出的都是对应项的数据。
• 目标行定位：用Range("A" & Rows.Count).End(xlUp).Row + 1精准定位Sheet2的下一个空白行，不会覆盖已有数据。

原代码的优化点 #

原代码依赖Select和Copy/Paste的操作逻辑，改成直接赋值Value的方式后，代码执行效率提升明显，同时也降低了因Excel环境变化导致的报错概率。

内容的提问来源于stack exchange，提问作者MichaelMC