Vba 提取并列出匹配单元格

我试图比较包含公司名称的两列（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列，即

设置MatchName=Sheets（“Sheet1”）。如果列C

，则设置单元格（i，3）

代码：

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

---

这是一个整洁的版本，正确使用C列，即

设置MatchName=Sheets（“Sheet1”）。如果列C

，则设置单元格（i，3）

代码：

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

---

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

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

---

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

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

---

对于初学者，应将其设置为MatchName=Sheets（“Sheet1”）。如果列C，则应将其设置为MatchName=Sheets（“Sheet1”）。如果列C为Hanks，则应将其设置为MatchName=Sheets（“Sheet1”）。如果列C为Hanks，则应将其设置为MatchName=Sheets（“Sheet1”）。但是，即使进行了这些更改，我也会得到相同的结果。没有发生任何事情。如果列A=B的行大于2，则列C会得到列B的值，这是肯定的。您能以其他方式显示一些数据吗？试一下最下面的版本，它是一个简化版本。你是否关闭了屏幕更新或其他什么？用F8逐步检查代码，并验证是否输入了循环以及.Range（“B”&.Rows.Count）.End（xlUp）.rowThank，但是即使做了这些更改，我也会得到相同的结果。没有发生任何事情。如果列A=B的行大于2，则列C会得到列B的值，这是肯定的。您能以其他方式显示一些数据吗？试一下最下面的版本，它是一个简化版本。你是否关闭了屏幕更新或其他功能？用F8逐步检查代码，并验证是否输入了循环以及.Range（“B”&.Rows.Count）.End（xlUp）.row问后续问题的适当方式是什么？我打算使用一种类似于我的原始代码的方法，并对其进行修改以完成更复杂的工作。我不熟悉数组，因此修改代码有点麻烦。请用更新的代码和/或示例数据提出新问题。如果你觉得这会有所帮助，请用一张写着“跟进”的便条链接回这个问题再次感谢问后续问题的适当方式是什么？我打算使用一种类似于我的原始代码的方法，并对其进行修改以完成更复杂的工作。我不熟悉数组，因此修改代码有点麻烦。请用更新的代码和/或示例数据提出新问题。如果你觉得这会有所帮助，请用一张写着“跟进”的便条链接回这个问题再次感谢