快速/高效的 VBA 代码，用于比较大型数据库约 9000 行的 excel 中的两列

问题描述

我正在尝试为不匹配的对应值编写高效且更快的 VBA 代码，这将：

• 对照 A1:A9000 检查 C 列的每个值
• 如果找到：复制 B 列和 C 列的值并将它们粘贴到找到的单元格值（在 B 列和 C 列中），同时删除旧的不匹配条目。

运行 for 循环最终会进行 9000*9000 计算，制作速度非常慢。我是初学者，不知道更快的方法。我知道 .Find 比使用 for 循环快得多。

以下是不匹配的样本数据：

A 列	B列	C 列
XYZ1	XYZ1 的评论	XYZ1
XYZ3	XYZ2 的评论	XYZ2
XYZ5
XYZ6	XYZ4 的评论	XYZ4
XYZ8	XYZ5 的评论	XYZ5
XYZ9

请注意，B 列和 C 列中的值将始终相互匹配并正确对应。 A AND B & C 之间的不匹配。

这是想要的结果：

A 列	B列	C 列
XYZ1	XYZ1 的评论	XYZ1
XYZ3
XYZ5	XYZ5 的评论	XYZ5
XYZ6
XYZ8
XYZ9

请注意，不能更改或更改 A 列。

这是我到目前为止所拥有的，但处理代码所需的时间太长了：

Sub Realign()
For i = 2 To 9000
Set Found = Sheets("Sheet1").Range("A:A").Find(What:=Worksheets("Sheet1").Cells(i,3).Value,_
                                                       LookIn:=xlValues,_
                                                       LookAt:=xlWhole,_
                                                       SearchOrder:=xlByRows,_
                                                       SearchDirection:=xlNext,_
                                                       MatchCase:=False)
        If Found Is nothing Then
            Worksheets("Sheet1").Cells(i,2).Value = ""
            Worksheets("Sheet1").Cells(i,3).Value = ""
         
        Else
            Found.Offset(0,1).Value = Worksheets("Sheet1").Cells(i,2).Value
            Found.Offset(0,2).Value = Worksheets("Sheet1").Cells(i,3).Value
End If
Next
Call Delete1
End Sub

Sub Delete1()

For i = 2 To 9000

If Not Worksheets("Sheet1").Cells(i,3).Value = Worksheets("Sheet1").Cells(i,1).Value Then

    Worksheets("Sheet1").Cells(i,2).Value = ""
    Worksheets("Sheet1").Cells(i,3).Value = ""
 
End If
Next

End Sub

解决方法

Match() 比 find 快：

编辑：重新设计以避免覆盖的机会（假设不存在重复项）

Sub Realign2()
    Dim ws As Worksheet,m,v,r As Long,arr,arr2
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    
    arr = ws.Range("A1:C9000").Value 'get data as array
    
    arr2 = arr                       'make a copy
    
    'clear columns 2 and 3 in arr
    For r = 2 To UBound(arr,1)
        arr(r,2) = ""
        arr(r,3) = ""
    Next r
    
    For r = 2 To UBound(arr2,1)
        v = arr2(r,3)
        If Len(v) > 0 Then
            m = Application.Match(v,ws.Range("A:A"),0)
            If Not IsError(m) Then
                arr(m,2) = arr2(r,2)
                arr(m,3) = arr2(r,3)
            End If
        End If
    Next r
    ws.Range("A1:C9000").Value = arr
    
End Sub