VBA Set Spalten gleich zueinander, wenn andere Spaltenwerte übereinstimmen

Question

Ich habe zwei Excel-Arbeitsblätter. Wenn die eindeutige ID-Spalte beider Tabellen übereinstimmt, dann möchte ich den Wert von Spalte C in Blatt 1 in Spalte H in Blatt 2 kopieren. Die eindeutige ID-Spalte in Blatt 1 ist Q, Blatt 2 ist F. Der folgende Code stimmt überein die IDs zwischen den Tabellen und löscht die Zeilen in Blatt 1, die keine Übereinstimmung in Blatt 2 haben. Ich habe versucht, die Schleife in diesem Code zu ändern, um zu erreichen, was ich brauche.

Ich glaube, die Zeile nach DANN in der Schleife ist alles, was geändert werden muss, und dann würde ich den letzten Abschnitt des Codes löschen, der Zeilen löscht. Ich kann mich irren.

Sub Compare() 
    Dim ws1 As Worksheet, ws2 As Worksheet 
    Dim c As Range, rng As Range 
    Dim lnLastRow1 As Long, lnLastRow2 As Long 
    Dim lnTopRow1 As Long, lnTopRow2 As Long 
    Dim lnCols As Long, i As Long 


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

    ' Duplicate Sheet 1 
    Worksheets("Sheet1").Activate 
    Sheets("Sheet1").Copy After:=Sheets(Sheets.Count) 
    ActiveSheet.Name = "RAW DATA" 
    DoEvents 
    Worksheets("Sheet1").Activate 

    lnTopRow1 = 2 'first row containing data in ws1 
    lnTopRow2 = 2 'first row containing data in ws2 

    'Find last cells containing data: 
    lnLastRow1 = ws1.Range("Q:Q").Find("*", Range("Q1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row 
    lnLastRow2 = ws2.Range("F:F").Find("*", Range("F1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row 

    Set rng = ws2.Range("F" & lnTopRow2 & ":F" & lnLastRow2) 

    lnCols = ws1.Columns.Count 
    ws1.Columns(lnCols).Clear 'Using the very right-hand column of the sheet 

    For i = lnLastRow1 To lnTopRow1 Step -1 
     For Each c In rng 
      If ws1.Range("Q" & i).Value = c.Value Then 
       ws1.Cells(i, lnCols).Value = "KEEP" ' Add tag to right-hand column of sheet if match found 
       Exit For 
      End If 
     Next c 
    Next i 

    ' Delete rows where the right-hand column of the sheet is blank 
    Set rng = ws1.Range(Cells(lnTopRow1, lnCols), Cells(lnLastRow1, lnCols)) 
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
    ws1.Columns(lnCols).Clear 
End Sub 

Answer 1

Es ist möglicherweise besser, die innere verschachtelte Schleife durch VBAs Anwendung des Arbeitsblatts MATCH function zu ersetzen. Wenn Sie einen nicht zusammenhängenden Bereich der zu entfernenden Zellen/Zeilen mit der Union method erstellen, während Sie gleichzeitig die Werte für die übereinstimmenden Zeilen übertragen, sollte dies mit einer deutlichen Geschwindigkeitssteigerung belohnt werden.

Option Explicit 

Sub CompareXferDelete() 
    Dim ws1 As Worksheet, ws2 As Worksheet 
    Dim delrng As Range 
    Dim lnTopRow1 As Long, lnLastRow1 As Long 
    Dim mrw As Variant, i As Long 

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

    With ws1 

     ' Duplicate Sheet 1 
     .Copy After:=.Parent.Sheets(.Parent.Sheets.Count) 
     .Parent.Sheets(.Parent.Sheets.Count).Name = "RAW DATA" & .Parent.Sheets.Count 

     'first row containing data in ws1 
     lnTopRow1 = 2 
     'Find last cells containing data: 
     lnLastRow1 = .Range("Q:Q").Find("*", .Range("Q1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row 
     'seed the rows to delete so it doesn't have to be checked each time it is unioned 
     Set delrng = .Range("Q" & lnLastRow1 + 1) 

     For i = lnLastRow1 To lnTopRow1 Step -1 
      mrw = Application.Match(.Cells(i, "Q").Value2, ws2.Columns("F"), 0) 
      If Not IsError(mrw) Then 
       'exists in Sheet2 - transfer value from ws1.C to ws2.H 
       ws2.Cells(mrw, "H") = .Cells(i, "C").Value2 
      Else 
       'does not exist in Sheet2 - add to delete list 
       Set delrng = Union(delrng, .Cells(i, "Q")) 
      End If 
     Next i 

     ' Delete the rows collected into the union 
     delrng.EntireRow.Delete 

     'reactivate Sheet1 (unnecessary for code operation; simplifies things for user) 
     .Activate 
    End With 

End Sub 

Answer 2

die so FOR-Schleife ersetzen:

For i = lnLastRow1 To lnTopRow1 Step -1 
    For Each c In rng 
     If ws1.Range("Q" & i).Value = c.Value Then 
      ' ws1.Cells(i, lnCols).Value = "KEEP" ' Add tag to right-hand column of sheet if match found 
Dim valueToCopy As String 
valueToCopy = ws1.Range("C" & i).Value 
      Worksheets("Sheet2").Activate 
      Range("H" & c.Row).Value = valueToCopy 
      Worksheets("Sheet1").Activate 
      Exit For 
     End If 
    Next c 
Next i 

Dies sollte jetzt funktionieren. Ich bevorzuge den anderen Vorschlag sowieso!