Excel VBA - Vergleichen Sie Werte in zwei Spalten und kopieren Sie übereinstimmende Zeile in neues Blatt

Question

Ich versuche, Spalte A in Blatt2 mit SpalteA in Blatt1 zu vergleichen, und wenn es eine Übereinstimmung gibt, kopieren Sie die Zeile von Blatt1 nach Blatt3. Hier ist der Code, den ich habe, aber es funktioniert nicht.

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

nach Ihrem Wortlaut:

Ich versuche Spalte A in sheet2 zu columnA in sheet1 zu vergleichen und wenn eine Übereinstimmung da ist, kopieren Sie die Zeile aus sheet1 Tabelle3.

können Sie versuchen, diese

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 

Answer 2

Wie von Scott Craner, Ihre Aktualisierung von lastRowM basierend auf foundTrue funktioniert nicht. foundTrue wird nicht wirklich benötigt, solange Sie jedes Mal, wenn Sie Sheet3 eine neue Zeile hinzufügen, lastRowM aktualisieren. Ich habe es in dem Code behalten, falls Sie do eine Nachricht anzeigen möchten, wenn der Wert nicht gefunden wird.

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