如何在VBA宏中跳过空行，复制指定列并清空原单元格

我正在编写VBA宏，要把"Pivot"工作表的O、P、Q、R列数据复制到"Table1"工作表的表格里。现在的问题是宏会粘贴空白值，导致目标表格出现空行。需求是：

• 仅粘贴包含有效数据的行（跳过空行）
• 复制完成后清空原工作表对应单元格内容

工作表截图说明：Pivot表包含顶部O-R列的动态数据行（从第12行开始），左侧第2-8行是固定筛选项（值在第2列），Table1是结构化表格，表头与Pivot表对应。

修改后的代码 #

Sub CopyCols()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual ' 提升运行速度
    
    Dim srcWS As Worksheet, desWS As Worksheet
    Dim srcLastRow As Long, desNextRow As Long
    Dim cell As Range
    Dim headerMap As Object ' 存储表头对应关系
    
    Set srcWS = Sheets("Pivot")
    Set desWS = Sheets("Table1")
    Set headerMap = CreateObject("Scripting.Dictionary")
    
    ' 1. 建立目标表头与源数据位置的映射
    ' 处理Pivot表第11行的表头（O、P、Q、R列对应第15-18列）
    Dim srcHeaderRow As Range
    Set srcHeaderRow = srcWS.Range("O11:R11")
    For Each cell In srcHeaderRow
        If cell.Value <> "" Then
            headerMap(cell.Value) = cell.Column
        End If
    Next cell
    
    ' 处理Pivot表左侧固定表头（第2-8行第1列）
    For i = 2 To 8
        If srcWS.Cells(i, 1).Value <> "" And srcWS.Cells(i, 2).Value <> "All" Then
            headerMap(srcWS.Cells(i, 1).Value) = i
        End If
    Next i
    
    ' 2. 获取源数据最后一行，遍历有效行
    srcLastRow = srcWS.Cells(srcWS.Rows.Count, "O").End(xlUp).Row ' 以O列为准确定最后一行
    desNextRow = desWS.Cells(desWS.Rows.Count, 1).End(xlUp).Row + 1 ' 目标表下一个空行
    
    ' 遍历源数据行（从第12行开始）
    For i = 12 To srcLastRow
        ' 检查当前行O-R列是否存在有效数据
        If Application.WorksheetFunction.CountA(srcWS.Range(srcWS.Cells(i, 15), srcWS.Cells(i, 18))) > 0 Then
            ' 匹配目标表头，写入对应数据
            For Each cell In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, desWS.Cells(1, desWS.Columns.Count).End(xlToLeft).Column))
                If headerMap.exists(cell.Value) Then
                    Dim srcPos As Variant
                    srcPos = headerMap(cell.Value)
                    ' 判断是列数据（O-R列）还是固定行数据（左侧筛选项）
                    If srcPos >= 15 And srcPos <= 18 Then
                        desWS.Cells(desNextRow, cell.Column).Value = srcWS.Cells(i, srcPos).Value
                    Else
                        desWS.Cells(desNextRow, cell.Column).Value = srcWS.Cells(srcPos, 2).Value
                    End If
                End If
            Next cell
            desNextRow = desNextRow + 1 ' 目标行下移
        End If
    Next i
    
    ' 3. 清空源数据对应单元格
    srcWS.Range("O12:R" & srcLastRow).ClearContents
    For i = 2 To 8
        If srcWS.Cells(i, 2).Value <> "All" Then
            srcWS.Cells(i, 2).ClearContents
        End If
    Next i
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

核心优化说明 #

• 跳过空行：通过CountA函数检查每行O-R列的非空单元格数量，仅当存在有效数据时才执行复制操作
• 高效表头匹配：用字典存储表头与源数据位置的映射，替代原代码中重复的Find操作，减少冗余逻辑
• 清空原数据：复制完成后直接清除源工作表O-R列的有效数据区域，以及左侧非"All"的筛选项单元格
• 性能优化：关闭屏幕更新和自动计算，大幅提升宏的运行速度

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