继续求助，优化运行速度？

陌路丢了谁

比对要求：数据1在sheet1中，要随时变换调整，数据2在sheet2中，模板基本不变。要比对的结果在sheet3中，即sheet1和sheet2中的B列相同，则在sheet3中拼接在一行。可能是一对一，也能是一对多，或多对多。。。原来的代码也是excelhome中大神写的，在此表示感谢，我初学者是望尘莫及。现在数据量越来越大，运行速度太慢。。他原来像是遍历法则搞的，，，求哪位大神出手，优化一下。附件因为文件限制2兆，所以sheet3没有运行数据。。。谢谢。

比对模板.rar (1.3 MB, 下载次数: 0)

2026-4-19 23:43 上传

点击文件名下载附件

北极虎

代码如下：
Sub TEST比对()
'先清空表的数据
    Cells.Select
    Cells.Delete Shift:=xlShiftUp
   

s1col = Sheets(1).[iv1].End(xlToLeft).Column
s2col = Sheets(2).[iv1].End(xlToLeft).Column

ReDim TARR(1 To 165500, 1 To s1col + s2col)
Application.ScreenUpdating = False
dteStart = Timer
Sheets(3).Select
Rows("2:165500").ClearContents
Cells.Font.ColorIndex = 0

Set DIC = CreateObject("SCRIPTING.DICTIONARY")
Set DIC1 = CreateObject("SCRIPTING.DICTIONARY")
Rng = Sheets(1).[a1].CurrentRegion
For r = 2 To UBound(Rng)
Y = Trim(Rng(r, 2))
If DIC.EXISTS(Y) Then
DIC(Y) = DIC(Y) & "," & r
Else
DIC(Y) = r
End If
Next
Rng1 = Sheets(2).[a1].CurrentRegion
For r = 2 To UBound(Rng1)
Y = Trim(Rng1(r, 2))
If DIC1.EXISTS(Y) Then
DIC1(Y) = DIC1(Y) & "," & r
Else
DIC1(Y) = r
End If
Next
K = DIC.KEYS
t = DIC.ITEMS

s1col = Sheets(1).[iv1].End(xlToLeft).Column
s2col = Sheets(2).[iv1].End(xlToLeft).Column

For IV = 0 To DIC.Count - 1
   Y = K(IV)
   WW = Split(t(IV), ",")
   For i = 0 To UBound(WW)
      If DIC1.EXISTS(Y) Then
            XX = Split(DIC1(Y), ",")
            For II = 0 To UBound(XX)
                    TR = TR + 1
                        For qq = 1 To s1col
                            TARR(TR, qq) = Rng(WW(i), qq)
                        Next
                        For qq = s1col + 1 To s1col + s2col
                            TARR(TR, qq) = Rng1(XX(II), qq - s1col)
                        Next
                        If UBound(WW)  0 Then
                                Range("A" & TR + 1).Font.ColorIndex = 3
                        End If
                        If UBound(XX)  0 Then
                                Range("E" & TR + 1).Font.ColorIndex = 3
                        End If
            Next II
      Else
           TR = TR + 1
            For qq = 1 To s1col
                  TARR(TR, qq) = Rng(WW(i), qq)
            Next
      End If
   Next i
    If DIC1.EXISTS(Y) Then DIC1.Remove Y
Next

t = DIC1.ITEMS
For i = 0 To DIC1.Count - 1
      XX = Split(t(i), ",")
         For II = 0 To UBound(XX)
            TR = TR + 1
                 For qq = s1col + 1 To s1col + s2col
                  TARR(TR, qq) = Rng1(XX(II), qq - s1col)
                Next
         Next II
Next i
[a2].Resize(TR, s1col + s2col) = TARR
Application.ScreenUpdating = True

Sheets("Sheet1").Select
    Range(Cells(1, 1), Cells(1, s1col)).Select
    Selection.Copy
    Sheets("Sheet3").Select
    Range(Cells(1, 1), Cells(1, s1col)).Select
    ActiveSheet.Paste
    Sheets("Sheet2").Select
    Range(Cells(1, 1), Cells(1, s2col)).Select
   
    Selection.Copy
    Sheets("Sheet3").Select
    ActiveSheet.Cells(1, s1col + 1).Select
    ActiveSheet.Paste
   
strTime = Format((Timer - dteStart), "0.00000")
MsgBox "运行过程:" & strTime & "秒"
    Application.CutCopyMode = False
'MsgBox "OK"

End Sub

北京首负

数组字典全用上了，没优化余地。

刘汐悦

让原作者改一下好了。

椰子蛋

谢谢关注。原作者联系不上了，好多年前写的。

文锦

图文搭配很好，理解更快。

打油诗人孔二己

对我帮助很大，解决了卡了很久的问题。

佛山针织曹

讲解细致，不容易踩坑。

李欣贵

我是来刷分的，嘿嘿

有缘遇到你

不错