如何在字典里塞数组？

zuodinia

chxw68 发表于 2024-9-4 11:00
有很多种解法，直接塞单元格区域对象最方便。

感谢老师解答，没想到有Union 这个函数

zuodinia

joy.008@163.com 发表于 2024-9-4 11:28
我猜楼主估计是要这种格式:
姓名        内容1        内容2        内容3        内容4
张飞        A,1        B,2        C,3        D,4

不不，是以下格式
姓名        内容1        内容2        内容3        内容4
张飞        A               B                C              D
张飞        1              2                3            4

joy.008@163.com

1111111111111

zjdh

chxw68 发表于 2024-9-4 11:00
有很多种解法，直接塞单元格区域对象最方便。

商权一下，作如下改动：
Sub test()
    .............
    With Worksheets("模板")
        For Each aa In d.keys
            .Cells.Clear
            d(aa).Copy .Range("a1")
            .Copy
    .................
    End With
End Sub
否则当中间重名行数加少时会有错误信息。

ykcbf1100

参与一下，2级字典

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.4    2级字典
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("模板")
   
6.     p = ThisWorkbook.Path & ""
   
7.     With Sheets("内容")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         c = .Cells(1, "XFD").End(1).Column
   
10.         arr = .[a1].Resize(r, c)
    
11.     End With
    
12.     For i = 2 To UBound(arr)
    
13.         s = arr(i, 1)
    
14.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
15.         d(s)(i) = Application.Index(arr, i)
    
16.     Next
    
17.     For Each k In d.keys
    
18.         sh.Copy
    
19.         Set wb = ActiveWorkbook
    
20.         m = d(k).Count
    
21.         With wb.Sheets(1)
    
22.             .Name = k
    
23.             .Cells(2, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
24.         End With
    
25.         wb.SaveAs p & k
    
26.         wb.Close
    
27.     Next
    
28.     Set d = Nothing
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    
32. 
    

复制代码

ykcbf1100

换一种写法，Union法

ykcbf1100

Union法

1. Sub ykcbf2()   '//2024.9.4    Union法
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("模板")
   
6.     p = ThisWorkbook.Path & ""
   
7.     With Sheets("内容")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         c = .Cells(1, "XFD").End(1).Column
   
10.         arr = .[a1].Resize(r, c)
    
11.         For i = 2 To UBound(arr)
    
12.             s = arr(i, 1)
    
13.             If Not d.Exists(s) Then
    
14.                 Set d(s) = .Cells(i, 1).Resize(1, c)
    
15.             Else
    
16.                 Set d(s) = Union(d(s), .Cells(i, 1).Resize(1, c))
    
17.             End If
    
18.         Next
    
19.     End With
    
20.     For Each k In d.keys
    
21.         sh.Copy
    
22.         With ActiveWorkbook
    
23.             d(k).Copy .Sheets(1).[a2]
    
24.             .Sheets(1).Name = k
    
25.             .SaveAs p & k
    
26.             .Close 0
    
27.         End With
    
28.     Next
    
29.     Set Rng = Nothing
    
30.     Set d = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

liulang0808

Sub test()
    Dim brr()
    Set d = CreateObject("scripting.dictionary")
    arr = Worksheets("内容").Range("a1").CurrentRegion
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 1)) Then
            ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2))
            For i = 1 To UBound(arr, 2)
                brr(1, i) = arr(j, i)
            Next i
            d(arr(j, 1)) = brr
        Else
            crr = d(arr(j, 1))
            For i = 1 To UBound(crr)
                If Len(crr(i, 1)) = 0 Then Exit For
            Next
            For x = 1 To UBound(arr, 2)
                crr(i, x) = arr(j, x)
            Next x
            d(arr(j, 1)) = crr
        End If
    Next j
    Application.ScreenUpdating = False
    Sheets("模板").Copy
    With ActiveWorkbook
        For Each k In d.keys
            Sheets("模板").UsedRange.Offset(1).ClearContents
            crr = d(k)
            For i = 1 To UBound(crr)
                If Len(crr(i, 1)) = 0 Then Exit For
            Next
            Sheets("模板").[a2].Resize(i, UBound(crr, 2)) = crr
            .SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
        Next k
        .Close
    End With
    Application.ScreenUpdating = True
End Sub

liulang0808

用数组不是太理想，供参考