如何在字典里塞数组？

joy.008@163.com

liulang0808 发表于 2024-9-4 13:20
用数组不是太理想，供参考

粘贴新模版的时候
            For i = 1 To UBound(crr)
                If Len(crr(i, 1)) = 0 Then Exit For
            Next
这个作用是什么 我尝试注释掉 也没有影响 所以有点不明所以

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.UsedRange.Value
   
5. For i = 2 To UBound(arr)
   
6.     s = arr(i, 1)
   
7.     t = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5)
   
8.     If Not dic.exists(s) Then
   
9.         dic(s) = t
   
10.     Else
    
11.         dic(s) = dic(s) & "|" & t
    
12.     End If
    
13. Next
    
14. Application.ScreenUpdating = False: Application.DisplayAlerts = False
    
15. For Each k In dic.keys
    
16.         Sheet2.Copy
    
17.         With ActiveWorkbook
    
18.             .Sheets("模板").Range("a2:e1000") = ""
    
19.             ss = Split(dic(k), "|")
    
20.             ReDim brr(1 To UBound(ss) + 1, 1 To 5)
    
21.             m = 0
    
22.             For Each s In ss
    
23.                 m = m + 1
    
24.                 brr(m, 1) = k
    
25.                 xx = Split(s, ",")
    
26.                     For y = 0 To UBound(xx)
    
27.                         brr(m, y + 2) = xx(y)
    
28.                     Next
    
29.             Next
    
30.           .Sheets("模板").Range("a2").Resize(m, 5) = brr
    
31.             .SaveAs ThisWorkbook.Path & "" & k
    
32.             .Close False
    
33.         End With
    
34. Next
    
35. Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
36. End Sub
    

复制代码

Qs18

试试.........

Qs18

试试............

liulang0808

joy.008@163.com 发表于 2024-9-4 13:41
粘贴新模版的时候
            For i = 1 To UBound(crr)
                If Len(crr(i, 1)) = 0 Then ...

就是赋值的时候，范围问题，不修改，整个区域赋值也没有问题的

joy.008@163.com

liulang0808 发表于 2024-9-4 15:17
就是赋值的时候，范围问题，不修改，整个区域赋值也没有问题的

刚才测试了 发现brr和crr都是满格 我还在想每次更改数组大小怪麻烦的呢 这样更合理

joy.008@163.com

Qs18 发表于 2024-9-4 14:36
试试............

.SaveAs ThisWorkbook.Path & "" & k
应该是.SaveAs ThisWorkbook.Path & "/" & k
少了一个好像导不出来~~

Qs18

joy.008@163.com 发表于 2024-9-4 15:41
.SaveAs ThisWorkbook.Path & "" & k
应该是.SaveAs ThisWorkbook.Path & "/" & k
少了一个好像导不出 ...

我先测试一下再回复您

Qs18

都在，不知道哪一个没有导出来

Qs18

joy.008@163.com 发表于 2024-9-4 15:41
.SaveAs ThisWorkbook.Path & "" & k
应该是.SaveAs ThisWorkbook.Path & "/" & k
少了一个好像导不出 ...

哦，代码是少了斜杠，以文件附件为主要