如果其他列值匹配，VBA 將列設置為彼此相等

Question

我有兩個 Excel 工作表。 如果兩個電子表格的唯一 ID 列匹配，那么我想將工作表 1 中 C 列的值復制到工作表 2 中的 H 列。工作表 1 中的唯一 ID 列是 Q，工作表 2 是 F。下面的代碼匹配工作表之間的 ID 並刪除工作表 1 中在工作表 2 中沒有匹配項的行。我試圖修改此代碼中的循環以實現我所需要的。

我相信循環中 THEN 之后的行是所有需要修改的行，然后我將刪除刪除行的最后一段代碼。 我可能是錯的。

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

用 VBA 對工作表MATCH 函數的應用替換內部嵌套循環可能會更好。 如果您使用Union 方法構建要刪除的非連續單元格/行范圍，同時傳輸匹配行的值，您應該會獲得顯着的速度提升。

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

這樣替換 FOR 循環：

    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

這現在應該可以工作了。 無論如何，我更喜歡另一個建議！