Excel VBA宏复制筛选列仅复制单个可见单元格的问题求助

原代码中，SpecialCells(xlCellTypeVisible)返回的是筛选后所有可见单元格组成的不连续区域集合（Areas），但你的CopyValues子过程直接使用.Rows.Count时，只会读取第一个Area的行数，导致仅复制第一个可见区域（如果第一个可见区域是单个单元格，就只会复制这一个）。

不需要逐个遍历单元格，直接批量处理每个不连续的可见区域即可，同时保持操作的高效性。以下是修改后的完整代码：

Sub SelectAfile()
'Select a file Macro
    Dim FileLocation As String
    Dim LastRow As Long, wsPaste As Worksheet, curr_lrow As Long
    Dim wb As Workbook, ImportWorkbook As Workbook, wsImport As Worksheet
    
    'Open File
    FileLocation = Application.GetOpenFilename
    If FileLocation = "False" Then
        MsgBox "Please select a file.", vbCritical
        Exit Sub
    End If
    
    'Set variables for copy and destination sheets
    Set wb = ActiveWorkbook         'Destination workbook
    Set wsPaste = wb.Worksheets(1)  'Destination sheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual '进一步提升大数据量处理速度
    
    Set ImportWorkbook = Workbooks.Open(Filename:=FileLocation)
    Set wsImport = ImportWorkbook.Worksheets(2)
    
    '1. Find last used row in the copy range based on data in column A
    LastRow = wsImport.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
    '2. Find first blank row in the destination range based on data in column A 
    curr_lrow = wsPaste.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    '复制指定列的可见区域
    CopyVisibleValues wsImport.Range("A2:A" & LastRow), wsPaste.Range("A" & curr_lrow)
    CopyVisibleValues wsImport.Range("C2:C" & LastRow), wsPaste.Range("B" & curr_lrow)
    CopyVisibleValues wsImport.Range("D2:D" & LastRow), wsPaste.Range("C" & curr_lrow)
    
    ImportWorkbook.Close SaveChanges:=False '关闭源文件，不保存
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub CopyVisibleValues(rngFrom As Range, rngTo As Range)
    Dim area As Range
    Dim destRow As Long
    
    destRow = rngTo.Row '初始目标行
    
    '遍历每个可见区域，批量写入值
    For Each area In rngFrom.SpecialCells(xlCellTypeVisible).Areas
        With area
            wsPaste.Range(wsPaste.Cells(destRow, rngTo.Column), wsPaste.Cells(destRow + .Rows.Count - 1, rngTo.Column)).Value = .Value
            destRow = destRow + .Rows.Count '更新目标行
        End With
    Next area
End Sub

• 新增CopyVisibleValues子过程，遍历筛选后的每个不连续区域（Area），批量将每个Area的值写入目标区域，避免逐个单元格操作
• 加入Application.Calculation = xlCalculationManual临时关闭自动计算，进一步提升大数据量下的运行速度
• 处理完成后自动关闭源文件，恢复屏幕更新和自动计算

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