字典学习 输出表格

cqjinxin

grf1973 发表于 2024-6-25 10:57
把同一船号、同一日期的写在一个单元格里？

老哥这个比较接近答案了 很厉害了  还是谢谢 要是能分开更好 更直观

wang-way

也就是你 你这个需求  应该再嵌一层字典  行    不同船号   不同日期   不同行

wang-way

双层字典貌似也行 就是输出的时候要考虑行的问题

cqjinxin

wang-way 发表于 2024-6-25 11:10
双层字典貌似也行 就是输出的时候要考虑行的问题

  输出的时候脑子就绕不过来了

longwin

请看附件。。。。。

longwin

Sub 循环船号填表() ' By longwin 20240625
    Set d = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    arr = Range("A2:C" & [c2].End(xlDown).Row)
    For i = 1 To UBound(arr)
        If Not d.exists(CStr(arr(i, 1))) Then Set d(CStr(arr(i, 1))) = CreateObject("scripting.dictionary")
        If Not d(CStr(arr(i, 1))).exists(arr(i, 3)) Then Set d(CStr(arr(i, 1)))(arr(i, 3)) = CreateObject("scripting.dictionary")
        If Not d(CStr(arr(i, 1)))(arr(i, 3)).exists(arr(i, 2)) Then Set d(CStr(arr(i, 1)))(arr(i, 3))(arr(i, 2)) = CreateObject("scripting.dictionary")
        d(CStr(arr(i, 1)))(arr(i, 3))(arr(i, 2)) = 1
    Next
    brr = Range("H7:AM7")
    For i = 2 To UBound(brr, 2)
        d2(brr(1, i)) = i
    Next
    ReDim crr(1 To 1000, 1 To 32)
    m = 1:    j = 0
    For Each key1 In d.keys
        k = 0: m = m + k
        For Each key2 In d(key1).keys
            j = 0
            For Each key3 In d(key1)(key2).keys
                crr(m + j, 1) = key1
                crr(m + j, d2(key2)) = key3
                j = j + 1
                If k <= j Then k = j
            Next
        Next
    Next
    Range("H8:AM" & [h8].End(xlDown).Row).ClearContents
    [h8].Resize(m + j, 32) = crr
    Set d = Nothing
    Set d2 = Nothing
End Sub

wang-way

longwin 发表于 2024-6-25 12:02
请看附件。。。。。

思维能力真好   

半百

1. Sub 循环船号填表()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. ar = [a1].CurrentRegion
   
4. For i = 2 To UBound(ar)
   
5.     s = ar(i, 1) & "|" & ar(i, 3)
   
6.     d(s) = d(s) & "," & ar(i, 2)
   
7. Next
   
8. ReDim br(1 To i, 1 To 33)
   
9. For Each k In d.keys
   
10.     b = Split(k, "|")
    
11.     If Not d.exists(b(0)) Then d(b(0)) = r
    
12.     a = Split(d(k), ",")
    
13.     n = d(b(0))
    
14.     For i = 1 To UBound(a)
    
15.         n = n + 1
    
16.         br(n, 1) = n
    
17.         br(n, 2) = b(0)
    
18.         br(n, Day(b(1)) + 2) = a(i)
    
19.     Next
    
20.     If n > r Then r = n
    
21. Next
    
22. [g8].Resize(r, 33) = br
    
23. End Sub
    

复制代码

cqjinxin

longwin 发表于 2024-6-25 12:02
请看附件。。。。。

感谢大佬  确实很厉害 输出的地方我再学习学习

cqjinxin

半百 发表于 2024-6-25 12:32

大佬好厉害 我得好好扣你的代码一个一个翻译 偷学