如何修改VBA代码实现多列筛选数据按原顺序格式粘贴？

嘿，我瞅了下你的代码问题——原来的逻辑在处理单列时没问题，但多列的时候，因为你是逐个单元格复制，而且目标区域每次只往下偏移一行，完全没考虑列的对应关系，所以所有列的内容都被堆到目标的第一列里了。

下面是修改后的代码，能保证多列筛选数据按原列顺序和格式粘贴到目标区域，同时只处理可见行：

Sub Filtered_Cells()
    Dim fromRange As Range
    On Error Resume Next
    Set fromRange = Application.InputBox("选择要复制的筛选后区域", Type:=8)
    On Error GoTo 0
    
    If fromRange Is Nothing Then Exit Sub ' 用户取消选择
    
    ' 只选中可见单元格
    Set fromRange = fromRange.SpecialCells(xlCellTypeVisible)
    Copy_Filtered_Cells fromRange
End Sub

Sub Copy_Filtered_Cells(sourceRange As Range)
    Dim targetRange As Range
    Dim sourceRows As Collection
    Dim targetRows As Collection
    Dim srcRow As Variant, tgtRow As Variant
    Dim srcCol As Integer, tgtCol As Integer
    Dim i As Integer
    
    On Error Resume Next
    Set targetRange = Application.InputBox("选择要粘贴到的目标区域", Type:=8)
    On Error GoTo 0
    
    If targetRange Is Nothing Then Exit Sub ' 用户取消选择
    
    ' 收集源区域的可见行行号（去重，因为一行多列的话会重复）
    Set sourceRows = New Collection
    On Error Resume Next
    For Each cell In sourceRange
        sourceRows.Add cell.Row, Key:=CStr(cell.Row)
    Next
    On Error GoTo 0
    
    ' 收集目标区域的可见行行号
    Set targetRows = New Collection
    On Error Resume Next
    For Each cell In targetRange
        If cell.EntireRow.RowHeight > 0 Then
            targetRows.Add cell.Row, Key:=CStr(cell.Row)
        End If
    Next
    On Error GoTo 0
    
    ' 如果源可见行数和目标可见行数不匹配，提示用户
    If sourceRows.Count <> targetRows.Count Then
        MsgBox "源区域可见行数与目标区域可见行数不匹配，无法完成粘贴！"
        Exit Sub
    End If
    
    ' 逐行逐列对应粘贴
    Application.ScreenUpdating = False ' 关闭屏幕刷新，提升速度
    For i = 1 To sourceRows.Count
        srcRow = sourceRows(i)
        tgtRow = targetRows(i)
        
        For srcCol = 1 To sourceRange.Columns.Count
            ' 确保目标区域有足够的列数
            If srcCol > targetRange.Columns.Count Then Exit For
            
            tgtCol = targetRange.Column + srcCol - 1
            ' 复制源单元格值和格式（可以根据需求调整PasteSpecial的参数）
            sourceRange.Worksheet.Cells(srcRow, sourceRange.Column + srcCol - 1).Copy
            targetRange.Worksheet.Cells(tgtRow, tgtCol).PasteSpecial xlPasteAll
        Next
    Next
    Application.CutCopyMode = False ' 取消复制模式
    Application.ScreenUpdating = True ' 恢复屏幕刷新
    
    MsgBox "粘贴完成！"
End Sub

关键改动说明： #

• 分离行收集逻辑：先收集源区域的可见行行号（自动去重，避免一行多列重复统计），同时收集目标区域的可见行行号，只有两者行数匹配才执行粘贴，防止错位。
• 行列精准对应：源的第N个可见行对应目标的第N个可见行，源的第M列对应目标的第M列，彻底解决多列内容挤到单列的问题，完美保留原格式和顺序。
• 增强错误处理：添加了用户取消选择的判断，以及行数不匹配的弹窗提示，避免程序意外报错。
• 提升运行效率：粘贴前关闭屏幕刷新，完成后恢复，大幅减少操作时的卡顿感。

你可以直接替换原来的代码，测试一下多列筛选的情况——现在应该能准确按原列顺序把筛选后的内容粘贴到目标区域的对应列里了。

内容的提问来源于stack exchange，提问作者I Paul Ema