vba Excel 比较一张工作表中的两列将匹配的整行复制到新工作表

Excel compare two columns from one sheet copy entire row on match to new sheet

提问by Clepa

I am looking for VBA code that will do the following:

我正在寻找将执行以下操作的 VBA 代码：

• On Sheet 1, starting from A2, scroll down and compare each cell, one at a time, with each cell in the second column, starting with B2.
• If there is a match, copy entire row of matching entry in second column into Sheet 2
• If, after scrolling through column B, there were no matches, insert a blank row in Sheet 2

• 在工作表 1 上，从 A2 开始，向下滚动并比较每个单元格，一次一个，与第二列中的每个单元格（从 B2 开始）进行比较。
• 如果有匹配项，将第二列中匹配条目的整行复制到工作表 2 中
• 如果在滚动 B 列后没有匹配项，请在工作表 2 中插入一个空白行

Here is some pseudocode that may clarify what I'm looking for:

这是一些伪代码，可以阐明我在寻找什么：

For each cell in columnA
Traverse each cell in columnB
If current cell value in columnA matches current cell value in columnB
Copy the entire row at the current columnB position
If we have traversed the entire columnB and have not found a match
Insert a blank row in sheet2

对于 columnA 中的
每个单元格 遍历columnB 中的每个单元格
如果 columnA 中的当前单元格值与 columnB 中的当前单元格值匹配
复制当前 columnB 位置的整行
如果我们遍历了整个 columnB 并且没有找到匹配项
在 sheet2中插入一个空白行

Here is the best I could come up with, but I am not well-versed in manipulating excel sheets:

这是我能想到的最好的方法，但我不擅长操作 Excel 表格：

Sub rowContent()

Dim isMatch As Boolean
isMatch = False

Dim newSheetPos As Integer
newSheetPos = 1

Dim numRows As Integer
numRows = 591

Dim rowPos As Integer
rowPos = 1

For i = 1 To numRows 'Traverse columnA 
 For j = 1 To numRows 'Traverse columnB
    'Compare contents of cell in columnA to cell in ColumnB
    If Worksheets("Sheet1").Cells(i, 1) = Worksheets("Sheet1").Cells(j, 2) Then
        Worksheets("Sheet1").Cells(i, 1).Copy Worksheets("Sheet2").Cells(newSheetPos, 1)
        newSheetPos = newSheetPos + 1'prepare to copy into next row in Sheet2
        isMatch = True 
    End If

    j = j + 1 'increment j to continue traversing columnB
 Next
 'If we have traverse columnB without finding a match
 If Not (isMatch) Then 
        newSheetPos = newSheetPos + 1 'skip row in Sheet2 if no match was found
 End If
 isMatch = False
Next
End Sub

This code does not currently work.

此代码当前不起作用。

Many thanks for your kind help.

非常感谢您的帮助。

采纳答案by Netloh

I have made som changes to your code. This should work as your pseudocode-description:

我对您的代码进行了一些更改。这应该作为您的伪代码描述：

Sub rowContent()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long, j As Long
    Dim isMatch As Boolean
    Dim newSheetPos As Integer

    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")

    'Initial position of first element in sheet2
    newSheetPos = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row

    For i = 1 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        isMatch = False
        For j = 1 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
            If ws1.Cells(i, 1).Value = ws1.Cells(j, 2).Value Then
                ws1.Cells(j, 2).EntireRow.Copy ws2.Cells(newSheetPos, 1)
                isMatch = True
                newSheetPos = newSheetPos + 1
            End If
        Next j
        If isMatch = False Then newSheetPos = newSheetPos + 1
    Next i
End Sub