实现查找功能，因行数几十万行，所以用函数太慢了

pp000pp

用VLookup太慢了，行数太多好几十万行。

也试着用了FOR循环去查找。但还是慢的要命 。

一共有四张表，表1是主表，需要将表2至表3的符合条件的名称，放到表1对应单元格。


请大家帮了我看看要如何做呢。有人说数组，关键我不会。

q3698995

已完成，请查收！

今铭昔

pp000pp

今铭昔 发表于 2024-4-8 13:10

谢谢，但是我不看懂。

pp000pp

q3698995 发表于 2024-4-8 13:07
已完成，请查收！

Sub sx()

    Set d = CreateObject("scripting.dictionary")
   
    arr1 = Sheet3.Cells(1, 1).CurrentRegion.Value2
   
    For i = 2 To UBound(arr1)
        d("a " & arr1(i, 1)) = i
    Next
   
    arr2 = Sheet4.Cells(1, 1).CurrentRegion.Value2
    For i = 2 To UBound(arr2)
        d("b " & arr2(i, 1)) = i
    Next
        
    arr3 = Sheet5.Cells(1, 1).CurrentRegion.Value2
   
    For i = 2 To UBound(arr3)
        d("c " & arr3(i, 1)) = i
    Next
   
    arr = Cells(1, 1).CurrentRegion.Value2
   
    For i = 3 To UBound(arr)
        j = d("a " & arr(i, 7))
        If j Then arr(i, 1) = arr1(j, 3)
        arr(i, 2) = arr1(j, 2)
        
        j = d("b " & arr(i, 8))
        If j Then arr(i, 3) = arr2(j, 2)
        j = d("c " & arr(i, 5))
        If j Then arr(i, 4) = arr3(j, 2)
    Next
    Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)).Value2 = arr
   
    Set d = Nothing
   
End Sub

代码，运行了，但如果我的那三个表中没有主表中要查找到的信息时 ，代码报错。报下标越界

pp000pp

q3698995 发表于 2024-4-8 13:07
已完成，请查收！

你好，如果其它三表中没有主表中的匹配数据时，程序会报下标越界。

今铭昔

pp000pp 发表于 2024-4-8 13:40
谢谢，但是我不看懂。

我这个不是VBA，是JSA（WPS自家的宏）

q3698995

pp000pp 发表于 2024-4-8 13:56
你好，如果其它三表中没有主表中的匹配数据时，程序会报下标越界。

1. Sub sx()
   
2.     Dim j&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr1 = Sheet3.Cells(1, 1).CurrentRegion.Value2: For i = 2 To UBound(arr1): d("a " & arr1(i, 1)) = i: Next
   
5.     arr2 = Sheet4.Cells(1, 1).CurrentRegion.Value2: For i = 2 To UBound(arr2): d("b " & arr2(i, 1)) = i: Next
   
6.     arr3 = Sheet5.Cells(1, 1).CurrentRegion.Value2: For i = 2 To UBound(arr3): d("c " & arr3(i, 1)) = i: Next
   
7.     arr = Cells(1, 1).CurrentRegion.Value2
   
8.     For i = 3 To UBound(arr)
   
9.         j = d("a " & arr(i, 7)): If j Then arr(i, 1) = arr1(j, 3): arr(i, 2) = arr1(j, 2)
   
10.         j = d("b " & arr(i, 8)): If j Then arr(i, 3) = arr2(j, 2)
    
11.         j = d("c " & arr(i, 5)): If j Then arr(i, 4) = arr3(j, 2)
    
12.     Next: Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)).Value2 = arr: Set d = Nothing
    
13. End Sub

复制代码

ykcbf1100

用字典，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.8
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Application.Calculation = xlManual
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     Set d2 = CreateObject("Scripting.Dictionary")
   
8.     With Sheets("品分类")
   
9.         arr = .UsedRange
   
10.         For i = 2 To UBound(arr)
    
11.             s = CStr(arr(i, 1))
    
12.             d(s) = Array(arr(i, 3), arr(i, 2))
    
13.         Next
    
14.     End With
    
15.     With Sheets("合同")
    
16.         arr = .UsedRange
    
17.         For i = 2 To UBound(arr)
    
18.             s = CStr(arr(i, 1))
    
19.             d1(s) = arr(i, 2)
    
20.         Next
    
21.     End With
    
22.     With Sheets("销售分类")
    
23.         arr = .UsedRange
    
24.         For i = 2 To UBound(arr)
    
25.             s = CStr(arr(i, 1))
    
26.             d2(s) = arr(i, 2)
    
27.         Next
    
28.     End With
    
29.     With Sheets("Sheet2")
    
30.         r = .Cells(Rows.Count, "g").End(3).Row
    
31.         arr = .[a1].Resize(r, 9)
    
32.         For i = 3 To UBound(arr)
    
33.             s = CStr(arr(i, 7))
    
34.             arr(i, 1) = d(s)(0)
    
35.             arr(i, 2) = d(s)(1)
    
36.             s = CStr(arr(i, 8))
    
37.             arr(i, 3) = d1(s)
    
38.             s = CStr(arr(i, 5))
    
39.             arr(i, 4) = d2(s)
    
40.         Next
    
41.         .[a1].Resize(r, 9) = arr
    
42.     End With
    
43.     Set d = Nothing
    
44.     Set d1 = Nothing
    
45.     Set d2 = Nothing
    
46.     Application.Calculation = xlAutomatic
    
47.     Application.ScreenUpdating = True
    
48.     Application.DisplayAlerts = True
    
49.     MsgBox "OK！"
    
50. End Sub
    

复制代码