修改VBA代码：将指定行粘贴至Data表对应表头下方

当前VBA代码可复制Data工作表A列中，存在于Exceptions工作表A、B、C列的行，但仅能粘贴至Data表末尾。需修改代码实现：根据Exceptions表的分类（对应A/B/C列），将对应行粘贴至Data表的指定表头下方：

• 存在于Exceptions表A列的行，粘贴至Data表"A Description"表头下
• 存在于Exceptions表B列的行，粘贴至Data表"B Description"表头下
• 存在于Exceptions表C列的行，粘贴至Data表"C Description"表头下

现有代码 #

Sub CopyRow()

Dim lastRow As Long
Dim lRow As Long
Dim Data As String
Dim Exceptions As String

Data = "Data" 'Sheet name
Exceptions = "Exceptions" 'Sheet name
lastRow = Sheets(Data).Range("A" & Rows.Count).End(xlUp).Row

   For lRow = 2 To lastRow 'Loop through all rows

If Application.CountIf(Sheets(Exceptions).Columns("A"), Sheets(Data).Cells(lRow, "A").Value2) > 0 Then
 Sheets(Data).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets(Data).Rows(lRow).Value2
 End If
If Application.CountIf(Sheets(Exceptions).Columns("B"), Sheets(Data).Cells(lRow, "A").Value2) > 0 Then
 Sheets(Data).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets(Data).Rows(lRow).Value2
End If
If Application.CountIf(Sheets(Exceptions).Columns("C"), Sheets(Data).Cells(lRow, "A").Value2) > 0 Then
 Sheets(Data).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = Sheets(Data).Rows(lRow).Value2
End If

Next lRow

End Sub

修改后的代码 #

Sub CopyRowToTargetSection()
    Dim wsData As Worksheet, wsExceptions As Worksheet
    Dim lastRowData As Long, lRow As Long
    Dim targetHeader As String, targetRow As Long
    Dim cellValue As Variant
    
    ' 绑定工作表对象
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsExceptions = ThisWorkbook.Worksheets("Exceptions")
    
    lastRowData = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Row
    
    ' 遍历Data表数据行（跳过表头）
    For lRow = 2 To lastRowData
        cellValue = wsData.Cells(lRow, "A").Value2
        
        ' 判断当前值所属分类，匹配目标表头
        If Application.CountIf(wsExceptions.Columns("A"), cellValue) > 0 Then
            targetHeader = "A Description"
        ElseIf Application.CountIf(wsExceptions.Columns("B"), cellValue) > 0 Then
            targetHeader = "B Description"
        ElseIf Application.CountIf(wsExceptions.Columns("C"), cellValue) > 0 Then
            targetHeader = "C Description"
        Else
            ' 不在例外列表中，跳过当前行
            GoTo NextRow
        End If
        
        ' 定位目标表头所在行
        targetRow = wsData.Cells.Find(What:=targetHeader, LookIn:=xlValues, LookAt:=xlWhole).Row
        
        ' 在表头下方插入新行并复制数据
        wsData.Rows(targetRow + 1).Insert Shift:=xlDown
        wsData.Rows(lRow).Copy Destination:=wsData.Rows(targetRow + 1)
        
NextRow:
    Next lRow
End Sub

代码说明 #

• 通过Find方法动态定位目标表头位置，无需硬编码行号，适配表头位置变动的场景
• 针对每行数据判断所属分类，精准匹配对应目标表头
• 在目标表头下方插入新行并复制数据，替代原有的追加到表尾逻辑
• 加入跳过机制，直接忽略不在例外列表中的行，提升执行效率

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