如何用vba快速做大量数据匹配

ynzsvt

幽默的熊 发表于 2024-7-27 15:48
大佬, 怎么再字典数据组里面直接加呢, 求教!

从3楼改来的

1. Option Explicit
   
2. 
   
3. Sub 字典()
   
4. Dim arr, brr, Crr, i&
   
5. Dim dic As Object
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. arr = Sheets("2").UsedRange
   
8. For i = 2 To UBound(arr)
   
9.   If Len(arr(i, 1)) Then
   
10.    dic(arr(i, 1)) = arr(i, 2)
    
11.   End If
    
12. Next
    
13. 
    
14. brr = Sheets("1").[a1].CurrentRegion
    
15. ReDim Crr(1 To UBound(brr), 1 To 1)
    
16. For i = 2 To UBound(brr)
    
17.   If dic.exists(brr(i, 1)) Then
    
18.    Crr(i, 1) = dic(brr(i, 1))
    
19.   End If
    
20. Next
    
21. Crr(1, 1) = "3"
    
22. Sheets(1).[c1].Resize(UBound(Crr), 1) = Crr
    
23. End Sub

复制代码

sdytsxd991122

幽默的熊 发表于 2024-7-27 15:16
感谢大佬, 还有一个问题, 如果A列是文本格式的长数字, 这样做完了之后, A列就变成科学计数法了, 最后一位 ...

数组返回单元格之前，单元格设置为文本格式

幽默的熊

sdytsxd991122 发表于 2024-7-27 16:52
数组返回单元格之前，单元格设置为文本格式

总算是整明白了! 感谢

titi012

参与一下。
使用排序加二分法，一秒内完成。
不过好像能配上的数据不多。

1. Sub tt()
   
2.    
   
3.     Dim Arr, Brr
   
4.     Dim i&, j&, T$, x&, y&, N&
   
5.     Dim t1, t2
   
6.     t1 = Timer
   
7.    
   
8.     With Sheets("1")
   
9.         j = .Cells(Rows.Count, 1).End(xlUp).Row
   
10.         Arr = .Range("a2:c" & j)
    
11.     End With
    
12.    
    
13.     With Sheets("2")
    
14.         .Activate
    
15.         i = .Cells(Rows.Count, 1).End(xlUp).Row
    
16.         .Range("a1:b" & i).Sort key1:=[a1], Order1:=1, Header:=xlYes
    
17.         Brr = .Range("a2:b" & i)
    
18.     End With
    
19.    
    
20.     For i = 1 To UBound(Arr)
    
21.         T = Arr(i, 1)
    
22.         x = LBound(Brr)
    
23.         y = UBound(Brr)
    
24.         Do
    
25.             N = (x + y) / 2
    
26.             If Brr(N, 1) < T Then
    
27.                 x = N + 1
    
28.             ElseIf Brr(N, 1) > T Then
    
29.                 y = N - 1
    
30.             Else
    
31.                 Arr(i, 3) = Brr(N, 2)
    
32.                 Exit Do
    
33.             End If
    
34.         Loop While x <= y
    
35.     Next i
    
36.    
    
37.     With Sheets("1")
    
38.         .Activate
    
39.         .Range("a2:c" & j) = Arr
    
40.     End With
    
41.    
    
42.     t2 = Timer
    
43.     MsgBox t2 - t1
    
44.    
    
45. End Sub

复制代码

shiruiqiang

dic("'" & arr(x,1))
前面+“’”

幽默的熊

titi012 发表于 2024-7-27 18:13
参与一下。
使用排序加二分法，一秒内完成。
不过好像能配上的数据不多。

还是大神们厉害！

幽默的熊

shiruiqiang 发表于 2024-7-27 18:32
dic("'" & arr(x,1))
前面+“’”

表示学到了！

chenyun1234

我的留个印记，下次好找门

ykcbf1100

这个题目昨天刚做过。

再做一次吧，已考虑到A列为文本数值情况。

ykcbf1100

如果A列为文本。

1. Sub ykcbf()   '//2024.7.29
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("2")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 2)
   
7.     End With
   
8.     For i = 2 To UBound(arr)
   
9.         s = CStr(arr(i, 1))
   
10.         d(s) = arr(i, 2)
    
11.     Next
    
12.     With Sheets("1")
    
13.         r = .Cells(Rows.Count, 1).End(3).Row
    
14.         arr = .[a1].Resize(r, 3)
    
15.         For i = 2 To UBound(arr)
    
16.             s = CStr(arr(i, 1))
    
17.             If d.exists(s) Then
    
18.                 arr(i, 3) = d(s)
    
19.             End If
    
20.         Next
    
21.         .[c1].Resize(r, 1) = Application.Index(arr, 0, 3)
    
22.     End With
    
23.     Set d = Nothing
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    
27. 
    

复制代码