Excel Vba - 如何将匹配的行从一张表复制并粘贴到另一张表中完全匹配的行下方

Question

我在 excel vba 场景中相当新。我想在这个宏中完成的是，

我有两张表，两列，sheet1 列 A，sheet2 列 A，在 A 列中都有可能的匹配项。我试图找到两张表之间的所有匹配项，并将匹配的整行从 sheet1 复制到匹配行的正下方在带有 sheet1 标题的第二张表中。

sheet1

数据-----------名称

012------------AAA

022-----------BBB

033------------CCC

Sheet2

id-----------地址

012-----------纽约

021-----------费城

033------------CT

结果

id-----------地址

012-----------纽约

数据-----------名称

012------------AAA

021-----------费城

033------------CT

数据-----------名称

033------------CCC

目前我只复制第一行的代码，不知道如何修复它。

Sub oneMacro()
Dim lastrowone As Integer, lastrowtwo As Integer
lastrowone = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrowtwo = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lastrowone
    For j = 2 To lastrowtwo
        If Sheets("Sheet1").Cells(i, "A").Value = Sheets("Sheet2").Cells(j, "A").Value Then
            Sheets("Sheet1").Cells(i, "A").EntireRow.Copy
            Sheets("Sheet2").Cells(j, "A").Offset(1).Insert Shift:=xlDown
        End If
    Next j
Next i
End Sub

Answer 1

您的代码存在一些问题。首先，为了帮助您了解如何解决这个问题……首先，您需要添加一些断点，并设置一些手表。但是您会发现，您的循环一开始设置得很完美，但在添加数据时并没有正确适应。

您的循环语句几乎会继续循环，直到您的点击 lastrowtwo 最初设置为值 3（基于您上面的示例）。相反，您的代码需要在每次找到lastrowtwo 变量的真实结果时添加+1。我已在下面修改了您的代码以解决此问题。

另一个问题是您要应对从一个单元到另一个单元的所有内容，然后将其向下移动。执行此操作时，您将比较下一个（将作为匹配返回）。一段时间后，您会看到这只会扫描第一个行项目。要克服这个问题，您可以简单地跳过循环检查语句中的下一行。您可以通过将+1 添加到j 变量来做到这一点。修改见下文。

Sub oneMacro()
Dim lastrowone, lastrowtwo As Long

lastrowone = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrowtwo = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrowone
    For j = 2 To lastrowtwo
        If Sheets("Sheet1").Cells(i, 1).Value = Sheets("Sheet2").Cells(j, 1).Value Then
            Sheets("Sheet1").Cells(i, 1).EntireRow.Copy
            Sheets("Sheet2").Cells(j, 1).Offset(1).Insert Shift:=xlDown
            j = j + 1 ' Modified = this must be added to overcome an issue with DOUBLE checking the newly inserted data
            lastrowtwo = lastrowtwo + 1 ' Modified = This is added to overcome an issue with not completing all rows
        End If
    Next j
Next i

End Sub