求助能否让字典的一个key对应多条item

spin2016

zmj9151 发表于 2018-10-12 17:29
两重字典，或数组redim preserve

谢谢老师，不过我不懂怎么做两重字典，老师能否试例下。追加数组是一个思路，我试着写下。

spin2016

excelvlookup 发表于 2018-10-12 17:31
arr = Range("b2:c8")
Set d = CreateObject("scripting.dictionary") ' 字典法
d.add "赵一",arr

多谢老师，这个方法好，不过有一点就是要先循环出对应赵一，赵二，赵四的日期和数量的组成数组，然后加入字典。如果条目很多的话，是不是可能会很慢，不知道我这样理解对不对

excelvlookup

spin2016 发表于 2018-10-12 18:01
多谢老师，这个方法好，不过有一点就是要先循环出对应赵一，赵二，赵四的日期和数量的组成数组，然后加入 ...

具体说说要做什么，不清楚做什么没法回答

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         m = 1
    
12.         ReDim brr(1 To 2, 1 To m)
    
13.       Else
    
14.         brr = d(arr(i, 1))
    
15.         m = UBound(brr, 2) + 1
    
16.         ReDim Preserve brr(1 To 2, 1 To m)
    
17.       End If
    
18.       brr(1, m) = arr(i, 2)
    
19.       brr(2, m) = arr(i, 3)
    
20.       d(arr(i, 1)) = brr
    
21.     Next
    
22.   End With
    
23.   For Each aa In d.keys
    
24.     brr = d(aa)
    
25.     ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
26.     For i = 1 To UBound(brr)
    
27.       For j = 1 To UBound(brr, 2)
    
28.         crr(j, i) = brr(i, j)
    
29.       Next
    
30.     Next
    
31.     d(aa) = crr
    
32.   Next
    
33. End Sub
    

复制代码

chxw68

详见附件。

spin2016

chxw68 发表于 2018-10-12 18:40

多谢老师，运行很成功