Question

我正在尝试比较包含公司名称的两列（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

Answer 1

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

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

代码：

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

Answer 2

尝试使用数组在内存中进行处理，并在可以使用更快的“证明存在”方法时避免循环。

Sub matchComps()
    Dim i As long, j As long, arrA as variant, arrB as variant, arrC as variant

    with workSheets("Sheet1")
        arrA = .range(.cells(3, "A"), .cells(.rows.count, "A").end(xlup)).value2
        arrb = .range(.cells(3, "B"), .cells(.rows.count, "B").end(xlup)).value2
        redim arrc(1 to application.min(ubound(arra, 1) ,ubound(arrb, 1)), 1 to 1)

        for i= lbound(arra, 1) to ubound(arra, 1) 
            if not iserror(application.match(arra(i, 1), arrb, 0)) then
                j=j+1
                arrc(j,1) = arra(i, 1)
            end if
        next i

        .cells(3, "C").resize(ubound(arrc, 1), ubound(arrc, 2)) = arrc
    end with

End Sub

提取并列出匹配单元格

2 个答案: