VBA 如何用字典和数组代替vlookup

smile121212

请教大神们如何用字典和数组代替VLookup的功能~
如附件，只涉及到两张表，需要按“数据源”表中的“物料”字段，将四项匹配到“匹配后的数据"表中。

自己搜过一些字典和数组的代码，但还是不太会用，主要卡在”匹配后的数据“表中"物料”和要匹配的四项信息不是在连续的列中，不知道代码怎么改~
麻烦大神们顺便标注一下代码大概的意思，拜谢~

lsc900707

这样的案例论坛里一定能找到！

astupig

1. Sub RLookup()
   
2.     Dim i As Long, j As Integer, dataArr, matchArr
   
3.     Dim dic As Object
   
4.    
   
5.     Set dic = CreateObject("Scripting.Dictionary")
   
6.     Sheets("数据源").Activate
   
7.     dataArr = [a1].CurrentRegion
   
8.     Sheets("匹配后的数据").Activate
   
9.     matchArr = [a1].CurrentRegion
   
10.    
    
11.     For i = 2 To UBound(dataArr)
    
12.         dic(dataArr(i, 1)) = dataArr(i, 2) & "," & dataArr(i, 3) & "," & dataArr(i, 4) & "," & dataArr(i, 5)
    
13.     Next i
    
14.     For i = 2 To UBound(matchArr)
    
15.         For j = 6 To 9
    
16.             If dic.exists(matchArr(i, 2)) Then
    
17.                 matchArr(i, j) = Split(dic(matchArr(i, 2)), ",")(j - 6)
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     Sheets("匹配后的数据").[a1].Resize(UBound(matchArr), UBound(matchArr, 2)) = matchArr
    
22. End Sub
    

复制代码

鄂龙蒙

1. <div class="blockcode"><blockquote>Sub 用字典和数组代替vlookup()
   
2.     Dim m, i, j, x, k, t, arr, brr
   
3.     Dim d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     [F2:L10000] = Empty
   
6.     arr = Sheet1.Range("A1").CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.          If Not d.exists(arr(i, 1)) Then
   
9.             m = 1
   
10.             ReDim brr(1 To 4, 1 To m)
    
11.         Else
    
12.             brr = d(arr(i, 1))
    
13.             m = UBound(brr, 2) + 1
    
14.             ReDim Preserve brr(1 To 4, 1 To m)
    
15.         End If
    
16.         For j = 1 To 4
    
17.             brr(j, m) = arr(i, j + 1)
    
18.         Next
    
19.         d(arr(i, 1)) = brr
    
20.     Next
    
21.     k = d.keys
    
22.     t = d.items
    
23.     arr = Range("A1").CurrentRegion
    
24.     For i = 2 To UBound(arr)
    
25.         For x = 0 To d.Count - 1
    
26.             If arr(i, 2) = k(x) Then
    
27.                 For j = 1 To 4
    
28.                     Cells(i, j + 5) = t(x)(j, 1)
    
29.                 Next
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     Set d = Nothing
    
34. End Sub

复制代码

smile121212

朱荣兴 发表于 2019-6-18 08:40
Sub test() '''QQ:705664849
Set d = CreateObject("scripting.dictionary")
With Sheets("匹配后的数据" ...

请问如果将“物料”这列从原来的第2列改为第4列，代码要怎么改？

smile121212

astupig 发表于 2019-6-18 08:50

请问如果将“物料”这列从原来的第2列改为第4列，代码要怎么改？

smile121212

鄂龙蒙 发表于 2019-6-18 09:13

请问为什么要先写这句？
[F2:L10000] = Empty

smile121212

朱荣兴 发表于 2019-6-18 09:40
Sub test() '''QQ:705664849
Set d = CreateObject("scripting.dictionary")
With Sheets("匹配后的数 ...

非常感谢大神高效回复，有种茅塞顿开的感觉，哈哈哈~谢谢谢谢~