满足条件时用VBA将多工作表数据复制到指定工作簿

核心逻辑 #

• 遍历源工作簿「Mergefile」的所有工作表
• 仅处理可见行（自动跳过筛选隐藏的行）
• 判断每行第4列（D列）是否非空，满足条件则复制该行B-J列的非空数据到目标工作表的空白行

完整VBA代码 #

Sub CopyTargetData()
    Dim srcWb As Workbook, destWb As Workbook
    Dim srcWs As Worksheet, destWs As Worksheet
    Dim srcRange As Range, destRow As Long
    Dim i As Long, col As Long
    
    ' 若工作簿未提前打开，可替换为Workbooks.Open("文件完整路径")指定路径
    Set srcWb = Workbooks("Mergefile.xlsx") ' 根据实际扩展名调整
    Set destWb = Workbooks("Detail OD.xlsx")
    Set destWs = destWb.Worksheets("Data")
    
    ' 获取目标工作表B列最后一行，从下一行开始粘贴
    destRow = destWs.Cells(destWs.Rows.Count, "B").End(xlUp).Row + 1
    
    ' 遍历源工作簿的每个工作表
    For Each srcWs In srcWb.Worksheets
        ' 筛选出当前工作表的可见行范围
        On Error Resume Next
        Set srcRange = srcWs.UsedRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not srcRange Is Nothing Then
            ' 遍历可见行的每一行
            For i = 1 To srcRange.Rows.Count
                ' 检查当前行D列是否非空（去除首尾空格）
                If Trim(srcWs.Cells(srcRange.Rows(i).Row, 4).Value) <> "" Then
                    ' 遍历B-J列（第2到第10列）
                    For col = 2 To 10
                        ' 仅复制非空单元格内容到目标对应列
                        If Trim(srcWs.Cells(srcRange.Rows(i).Row, col).Value) <> "" Then
                            destWs.Cells(destRow, col).Value = srcWs.Cells(srcRange.Rows(i).Row, col).Value
                        End If
                    Next col
                    destRow = destRow + 1 ' 目标行下移一行
                End If
            Next i
        End If
    Next srcWs
    
    MsgBox "数据复制完成", vbInformation
End Sub

关键细节说明 #

• 忽略筛选行：通过SpecialCells(xlCellTypeVisible)直接获取可见行范围，无需手动判断行是否隐藏
• 仅复制非空数据：遍历B-J列每个单元格，仅当内容去除首尾空格后不为空时才执行复制
• 目标行定位：利用End(xlUp)精准定位目标工作表的最后数据行，避免覆盖已有数据
• 路径适配：如果工作簿未提前打开，将Set srcWb = ...替换为Set srcWb = Workbooks.Open("C:\你的文件路径\Mergefile.xlsx")即可

内容的提问来源于stack exchange，提问作者Khởi Nguyễn