提取并列出匹配的单元格

我试图比较包含公司名称的两列（A 和 B），找到任何完全匹配的名称，并将它们列在 C 列中。使用下面的代码，我没有收到错误，但什么也没有发生。如果有人能指出我正确的方向，我将不胜感激。

Sub match()
Dim LastRow As Integer
Dim i As Integer

LastRow = Range("B" & Rows.Count).End(xlUp).Row

For i = 3 To LastRow

Set Row2Name = Sheets("Sheet1").Cells(i, 2)
Set Row1Name = Sheets("Sheet1").Cells(i, 1)
Set MatchName = Sheets("Sheet1").Cells(i, 1)

If Cells(i, 2) = Row1Name Then
Row2Name.Copy
MatchName.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If
Next i

End Sub

这是正确使用 C 列的整理版本，即

Set MatchName = Sheets("Sheet1").Cells(i, 3) if column C.

Code:

Option Explicit

Public Sub matching()
    Dim LastRow As Long, i As Long, Row2Name As Range, Row1Name  As Range, MatchName As Range

    With Worksheets("Sheet1")
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row

        For i = 3 To LastRow

            Set Row2Name = .Cells(i, 2)
            Set Row1Name = .Cells(i, 1)
            Set MatchName = .Cells(i, 3)

            If .Cells(i, 2) = Row1Name Then
                Row2Name.Copy
                MatchName.PasteSpecial Paste:=xlPasteValues
            End If
        Next i
    End With
End Sub

本质上是这样的：

Option Explicit
Public Sub matching()
    Dim i As Long
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        For i = 3 To .Range("B" & .Rows.Count).End(xlUp).Row
            If .Cells(i, 1) = .Cells(i, 2) Then .Cells(i, 3) = .Cells(i, 2)
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

对于大量行，您可以使用数组在内存中完成这一切。

Public Sub matching()
    Dim arr(), i As Long
    With Worksheets("Sheet1")
        .Columns(3).ClearContents
        arr = .Range("A3:C" & .Range("B" & .Rows.Count).End(xlUp).Row).Value
        For i = LBound(arr, 1) To UBound(arr, 1)
            If arr(i, 1) = arr(i, 2) Then arr(i, 3) = arr(i, 2)
        Next i
        .Cells(3, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub