VBA循环匹配复制问题求助：重复粘贴与数据覆盖

我看了你这段写了一周的VBA代码，现在差5%就达到预期了，卡在两个匹配逻辑的问题上——Sheet1单个值对应Sheet2多个匹配行时重复粘贴，Sheet1多个值对应Sheet2单个行时覆盖原有数据，其实都是循环和匹配逻辑没做限制导致的，咱们来调整一下代码：

原代码的问题根源 #

你用了双层嵌套循环，把Sheet2的每个值和Sheet1的每个值逐一比对，只要匹配就粘贴，这就导致：

• 当Sheet1一个值在Sheet2有多个匹配时，会给所有匹配行都粘贴一遍
• 当Sheet1多个值对应Sheet2同一个行时，后面的匹配会覆盖前面粘贴的内容

修改后的代码（解决两个核心问题） #

Sub FillinAlegs()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim valueRng As Range, cell As Range
    Dim matchCell As Range
    Dim lastRow1 As Long
    
    ' 定义工作表对象，代码更简洁易读
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 获取Sheet1 E列的有效数据范围
    lastRow1 = ws1.Range("E" & ws1.Rows.Count).End(xlUp).Row
    Set valueRng = ws1.Range("E1:E" & lastRow1)
    
    ' 遍历Sheet1的每个数据项
    For Each cell In valueRng
        ' 在Sheet2的G列从G2开始，查找当前单元格的精确匹配项，只找第一个
        Set matchCell = ws2.Range("G:G").Find( _
            What:=cell.Value, _
            After:=ws2.Range("G2"), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            MatchCase:=False)
        
        If Not matchCell Is Nothing Then
            ' 先检查Sheet2匹配行的C列是否为空（判断是否已填充过数据）
            If ws2.Range("C" & matchCell.Row).Value = "" Then
                ' 复制Sheet1对应行的A:P列到Sheet2的C:R列
                ws1.Range("A" & cell.Row & ":P" & cell.Row).Copy _
                    Destination:=ws2.Range("C" & matchCell.Row & ":R" & matchCell.Row)
            End If
            ' 找到第一个匹配项后直接退出查找，避免重复粘贴到其他匹配行
            Exit Do
        End If
    Next cell
    
    Application.ScreenUpdating = True
    MsgBox "数据填充完成！"
End Sub

关键改进点说明 #

• 解决重复粘贴问题：用Find方法直接定位Sheet2中第一个匹配的行，找到后用Exit Do停止查找，不会再给其他匹配行重复粘贴
• 解决覆盖问题：粘贴前先判断Sheet2目标行的C列是否为空，只有空的时候才粘贴，确保已有的数据不会被后续匹配项覆盖
• 代码优化：用工作表变量替代重复的Worksheets("Sheet1")调用，结构更清晰；最后加了完成提示，操作更直观

可选需求：如果不想覆盖而是插入新行 #

要是你的需求是当Sheet1多个值对应Sheet2同一个匹配值时，不想覆盖原有数据，而是在Sheet2插入新行来存放后续匹配的数据，可以把代码里的判断部分改成这样：

If Not matchCell Is Nothing Then
    ' 如果目标行已填充数据，就在下方插入新行
    If ws2.Range("C" & matchCell.Row).Value <> "" Then
        matchCell.Offset(1).EntireRow.Insert Shift:=xlDown
        Set matchCell = matchCell.Offset(1)
    End If
    ' 复制数据到目标行
    ws1.Range("A" & cell.Row & ":P" & cell.Row).Copy _
        Destination:=ws2.Range("C" & matchCell.Row & ":R" & matchCell.Row)
    Exit Do
End If

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