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

【问题标题】：Excel compare two columns from one sheet copy entire row on match to new sheetExcel比较一张工作表中的两列将匹配的整行复制到新工作表
【发布时间】：2014-04-12 01:34:00
【问题描述】：

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

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

这里有一些伪代码可以说明我在寻找什么：

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

这是我能想到的最好的方法，但我并不精通处理 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 在什么情况下不起作用？它会产生错误吗？或者它只是没有达到你想要的结果？此外，如果找不到匹配项，您希望在 Sheet2 中插入空白行。在哪里？你会在哪一行插入空白行？

标签： excel vba

【解决方案1】：

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

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

【讨论】：