[已解决]用VBA字典实现查找两列数据

laoau138

用VBA字典实现查找两列数据

最佳答案

月排行榜 / 总排行榜

lisachen

2017-6-18 22:28

1. Sub test()
   
2.     Dim arr(), brr(1 To 1000, 1 To 2)
   
3.     Dim x, k, h
   
4.     Dim d
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A1").CurrentRegion
   
7.     For x = 2 To UBound(arr)
   
8.         If arr(x, 1) <> "" Then
   
9.             k = k + 1
   
10.             d(Cells(x, 6).Value & Cells(x, 7).Value) = k
    
11.         End If
    
12.     Next x
    
13. 
    
14.     For x = 2 To UBound(arr)
    
15.         If d.Exists(arr(x, 1) & arr(x, 2)) Then
    
16.             h = d(arr(x, 1) & arr(x, 2))
    
17.             brr(h, 1) = arr(x, 3)
    
18.             brr(h, 2) = arr(x, 4)
    
19.         End If
    
20.     Next x
    
21.     Range("h2").Resize(UBound(arr), 2) = brr
    
22. End Sub

复制代码

跳转到最佳答案楼层

lisachen

1. Sub test()
   
2.     Dim arr(), brr(1 To 1000, 1 To 2)
   
3.     Dim x, k, h
   
4.     Dim d
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A1").CurrentRegion
   
7.     For x = 2 To UBound(arr)
   
8.         If arr(x, 1) <> "" Then
   
9.             k = k + 1
   
10.             d(Cells(x, 6).Value & Cells(x, 7).Value) = k
    
11.         End If
    
12.     Next x
    
13. 
    
14.     For x = 2 To UBound(arr)
    
15.         If d.Exists(arr(x, 1) & arr(x, 2)) Then
    
16.             h = d(arr(x, 1) & arr(x, 2))
    
17.             brr(h, 1) = arr(x, 3)
    
18.             brr(h, 2) = arr(x, 4)
    
19.         End If
    
20.     Next x
    
21.     Range("h2").Resize(UBound(arr), 2) = brr
    
22. End Sub

复制代码

laoau138

lisachen 发表于 2017-6-18 22:28

果然是高手

laoau138

lisachen 发表于 2017-6-18 22:28

用VBA字典数组汇总2列多列

http://www.excelpx.com/thread-431268-1-1.html