多列筛选后复制可见单元格至新工作簿的VBA实现问题

原代码的核心问题 #

• 隐藏列操作未指定Products工作表，默认对当前活动表生效，导致本该隐藏的列没被隐藏，复制时自然会带出这些列。
• Set rng = ThisWorkbook.Worksheets("Products").Cells.SpecialCells(xlCellTypeVisible).Select 是错误写法：Select方法返回的是True/False，不能赋值给Range对象，这会导致rng变量失效，后续复制操作实际是复制了选中区域（可能不是你要的范围）。
• 直接复制整个工作表的Cells可见区域，范围过大，拖慢运行速度。

修正后的代码 #

Sub SelectedProducts()
    Dim newBook As Excel.Workbook
    Dim sourceSheet As Excel.Worksheet
    Dim visibleRng As Excel.Range
    
    ' 绑定源工作表，避免操作错误的表格
    Set sourceSheet = ThisWorkbook.Worksheets("Products")
    
    ' 批量隐藏不需要的列（合并连续列，简化代码）
    With sourceSheet
        .Range("E:E,G:H,J:J,M:M,O:Q").EntireColumn.Hidden = True
    End With
    
    ' 获取有数据的可见区域（缩小复制范围，提升运行速度）
    On Error Resume Next ' 防止没有可见单元格时程序报错
    Set visibleRng = sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' 检查是否获取到有效区域，避免空复制
    If Not visibleRng Is Nothing Then
        ' 新建工作簿
        Set newBook = Workbooks.Add
        ' 复制可见区域并完整保留原格式
        visibleRng.Copy
        newBook.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        Application.CutCopyMode = False ' 清除剪贴板，释放资源
        
        ' 根据内容自动调整行列大小
        With newBook.Worksheets("Sheet1")
            .Columns.AutoFit
            .Rows.AutoFit
        End With
    Else
        MsgBox "没有可见数据可复制！"
    End If
End Sub

关键修改说明 #

1. 指定源工作表：用sourceSheet变量绑定目标表格，所有操作都基于这个变量，彻底避免操作错表的问题。
2. 批量隐藏列：把连续列合并写（比如G:H代表G、H列），简化代码同时减少重复操作。
3. 缩小复制范围：用UsedRange代替Cells，只复制有数据的区域，大幅降低运行耗时；同时增加错误处理，防止无可见单元格时程序崩溃。
4. 完整保留格式：用xlPasteAllUsingSourceTheme粘贴，确保原列的列宽、单元格样式等格式被完整复制到新工作簿。
5. 自动调整行列：新增Columns.AutoFit和Rows.AutoFit，自动根据单元格内容调整列宽和行高。

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