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 function应用程序替换内部嵌套循环可能更好。如果您使用Union method构建要移除的单元格/行的非连续范围，同时传输与您匹配的行的值，则应获得明显的速度提升。

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

现在应该可以了。无论如何我更喜欢其他建议！

如果其他列值匹配，则VBA设置列彼此相等

2 个答案: