Excel VBA：将源工作簿匹配区域复制到目标工作簿同名工作表

需求 #

源工作簿Sheet1的E列从E6开始包含重复的动物名称，需将每个动物对应的C:F列整行数据，复制到已关闭的目标工作簿中与动物名称同名的工作表，粘贴位置为该工作表A列的第一个空白行。

示例 #

源工作簿Sheet1（关键列） #

目标工作簿 #

包含工作表：Insect、Dog、Cat、Bird、Rabbit，需将cat对应的数据粘贴到Cat表，Dog对应的数据粘贴到Dog表。

原错误代码 #

Dim sourceWB As Workbook
Dim sourceWC As Worksheet
Dim targetWB As Workbook
Dim lastrow As Long
Dim i As long
Dim pasteRow As Long
Dim currentCell As Range
Dim visiblecells As Range
Dim cell As Range
Dim foundNext As Boolen
Dim startCell As Range
Dim matchValue As Variant
Dim matchRange As Range
Dim matchCell As Range
Dim rowRange As Range
Dim wb As Workbook
Dim pasteCol As Long
Dim pasteCell As Range
Dim RowCount As Long
Dim endRow As Long
Dim found As Boolean
Dim targetColumn As String
Dim tcell As Range
Dim startRow As Long
Dim col As Variant
Set sourceWB = Workbooks.Open("workbook.xlsx")
Set sourceWC = sourceWB.Sheets("Sheet1")
sourceWC.Activate
RowCount = SourceWC.Range ("E6", sourcWC.Range("E6").End(xldown)).Count
For n=0 to RowCount -1
Set currentCell = ActiveCell
On Error Resume Next
Set visibleCells = currentCell.EnrtreColumn.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not visibleCells Is Nothing Then
foundNext = False
For Each cell In visibleCells
If cell.Row > currentCell.Row Then
cell.Select
foundNext = True
Exit For
End If
Next cell
If Not foundNext Then
MsgBox "No found"
End If
Else
MsgBox "No found"
End If
matchValue = startCell.Value
lastRow = Cells(Rows.Count, startCell.Column).End(xlUp).Row
Set rowRange = Range("C" & startCell.Column & ":F" & startCell.Row).End(xlUp).Row
Set matchRange = rowRange
For Each currentCell In Range(startCell.Offset(1,0), Cells(lastRow, startCell.Column))
Set rowRange = Range ("C" & currentCell.Row & ":F" & currentCell.Row)
Set matchRange = Union(matchRange, rowRange)
End If
Next currentCell
If Not matchRange is Nothing Then
partID = matchRange.Cells(1,3)
matchRange.copy
Set targetWB = Workbook.open("C:\desktop\result.xlsx")
For Each ws In targetWB.Worksheets
If ws.Name = partID Then
ws.Activate
Range("A" & Rows.Count).End(xlUp).Offset(1,0).Select
Set pasteCell = ws.Cells(ws.Rows.Count, PasteCol).End(xl.up).offset(1,0),Select
Matchrange.paste
End If
Next ws
Else
End If
Next
Else
MsgBox "No more rows found and paste below"
End if
Next
End Sub

代码问题排查 #

1. 拼写错误：sourcWC、EnrtreColumn、Boolen、Workbook.open、xl.up、Matchrange等变量/方法名拼写错误
2. 变量未初始化/定义：n、startCell、partID、PasteCol未定义或未赋值，导致逻辑中断
3. 循环结构错误：存在多余的End If、Next不匹配，导致语法报错
4. 范围引用错误：Range("C" & startCell.Column & ":F" & startCell.Row)逻辑错误，应为按行号引用而非列号
5. 冗余操作：不必要的Activate、Select操作，易引发错误且降低效率
6. 资源重复调用：每次循环都打开目标工作簿，造成资源浪费且可能引发文件锁定

修正后的代码 #

Sub CopyAnimalData()
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWB As Workbook
    Dim lastRow As Long
    Dim i As Long
    Dim animalName As String
    Dim targetWS As Worksheet
    Dim pasteRow As Long
    
    ' 打开源工作簿（替换为实际文件路径）
    Set sourceWB = Workbooks.Open("C:\你的路径\workbook.xlsx")
    Set sourceWS = sourceWB.Sheets("Sheet1")
    
    ' 打开目标工作簿（替换为实际文件路径）
    Set targetWB = Workbooks.Open("C:\desktop\result.xlsx")
    
    ' 获取源数据E列最后一行行号
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "E").End(xlUp).Row
    
    ' 遍历E6到最后一行的动物名称
    For i = 6 To lastRow
        animalName = Trim(sourceWS.Cells(i, "E").Value)
        ' 跳过空值行
        If animalName = "" Then GoTo NextRow
        
        ' 查找目标工作簿中同名工作表
        On Error Resume Next
        Set targetWS = targetWB.Worksheets(animalName)
        On Error GoTo 0
        
        ' 如果找到对应工作表，执行复制粘贴
        If Not targetWS Is Nothing Then
            ' 获取目标表A列第一个空白行
            pasteRow = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1
            ' 直接复制源数据C:F列到目标指定位置
            sourceWS.Range("C" & i & ":F" & i).Copy Destination:=targetWS.Range("A" & pasteRow)
        End If
        
NextRow:
    Next i
    
    ' 保存并关闭工作簿（按需启用）
    targetWB.Save
    sourceWB.Close SaveChanges:=False
    targetWB.Close
    
    MsgBox "数据复制完成！"
End Sub

关键修改说明 #

• 移除冗余的Activate、Select操作，直接通过对象引用操作单元格，避免触发不必要的界面交互
• 仅打开一次源和目标工作簿，避免重复IO操作造成的资源浪费
• 增加空值判断，跳过E列无动物名称的无效行
• 简化范围引用逻辑，直接按行号定位C:F列数据
• 增加工作表存在性判断，避免因目标表不存在引发报错
• 使用Copy Destination直接完成复制粘贴，提高代码执行效率

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