Excel VBA – 比较两列中的值并将匹配的行复制到新工作表中

我试图将sheet2中的A列与sheet1中的columnA进行比较，当有匹配时，将sheet1中的行复制到sheet3中。 这是我有的代码，但它不工作。

Sub compareAndCopy() Dim lastRowE As Integer Dim lastRowM As Integer Dim foundTrue As Boolean ' stop screen from updating to speed things up Application.ScreenUpdating = False lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row For i = 1 To lastRowE foundTrue = False For j = 1 To lastRowF If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then 'MsgBox ("didnt find string: " & Sheets("Sheet2").Cells(i, 2).value) Sheets("Sheet2").Rows(i).Copy Destination:= _ Sheets("Sheet3").Rows(lastRowM + 1) Exit For End If Next j If Not foundTrue Then lastRowM = lastRowM + 1 foundTrue = True End If Next i ' stop screen from updating to speed things up Application.ScreenUpdating = True End Sub 

Answer 1

正如Scott lastRowM指出的那样，基于foundTrue的lastRowM更新不起作用。 foundTrue并不是真的需要，只要每次向Sheet3添加新行时更新lastRowM 。 我已经保存在代码中，如果你想显示一个消息，如果没有find值。

 Sub compareAndCopy() Dim lastRowE As Long Dim lastRowF As Long Dim lastRowM As Long Dim foundTrue As Boolean ' stop screen from updating to speed things up Application.ScreenUpdating = False lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row For i = 1 To lastRowE foundTrue = False For j = 1 To lastRowF If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then lastRowM = lastRowM + 1 Sheets("Sheet2").Rows(i).Copy Destination:= _ Sheets("Sheet3").Rows(lastRowM) foundTrue = True Exit For End If Next j 'If Not foundTrue Then ' MsgBox ("didn't find string: " & Sheets("Sheet2").Cells(i, 2).value) 'End If Next i ' stop screen from updating to speed things up Application.ScreenUpdating = True End Sub 

Answer 2

遵循你的措辞：

我试图将sheet2中的A列与sheet1中的columnA进行比较，当有匹配时，将sheet1中的行复制到sheet3中。

你可以试试这个

 Sub RowFinder() Dim sheet1Data As Variant With Worksheets("Sht2") '<--| reference your worksheet 2 sheet1Data = Application.Transpose(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Value) End With With Worksheets("Sht1") '<--| reference your worksheet 1 With .Range("A1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one .AutoFilter field:=1, Criteria1:=sheet1Data, Operator:=xlFilterValues '<--| filter cells with sheet 2 column A values If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=Worksheets("Sht3").Range("A1") End With .AutoFilterMode = False End With End Sub