在两张纸上匹配单元格并复制粘贴匹配内容

Question

我对vba完全陌生。我有两个Excel工作表，并且我正在尝试比较和匹配两张工作表中一列中的单元格。如果找到匹配的单元格，则将复制相邻单元格的信息并将其粘贴到另一张纸（sheet1）上。

我有一个工作正常但不完整的代码。因为一列中有重复的单元格，所以代码一旦找到匹配项并复制粘贴信息，就会跳到下一个非重复的单元格。从而导致大量空白，丢失的单元格。有什么想法让它填补空白吗？

图片：

Sheet2：

Sub Button2_Click()
Dim lastRw1, lastRw2, nxtRw, m

  lastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
  lastRw2 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row
'Loop
     For nxtRw = 2 To lastRw2
'Search
        With Sheets(1).Range("A2:A" & lastRw1)
          Set m = .Find(Sheets(2).Range("B" & nxtRw), LookIn:=xlValues, lookat:=xlWhole)
'Copy
            If Not m Is Nothing Then
              Sheets(2).Range("C" & nxtRw & ":D" & nxtRw).Copy _
              Destination:=Sheets(1).Range("J" & m.Row)
            End If
        End With
     Next
End Sub

Answer 1

已更新：

我从您的Sheet2数据集中提取了一个小样本：

我还更新了您的代码，如下所示（主要更改-我将“查找”替换为“匹配”，以便找到匹配的行号）：

Dim lastRw1 As Long, lastRw2 As Long, nxtRw As Long, m As Long

lastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
lastRw2 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row

'Loop
 For nxtRw = 2 To lastRw1
    'Search
    With Sheets(1)
         m = Application.Match(.Range("A" & nxtRw).Value, _
                Sheets(2).Range("B1:B" & lastRw2), 0)
        'Copy
         If m Then
            Sheets(2).Range("C" & m & ":D" & m).Copy _
            Destination:=.Range("J" & nxtRw)
         End If
    End With
 Next

最终结果：