增加条件，根据模板输出，字典数组

yynrzwh

h2016

yynrzwh 发表于 2023-12-13 16:45

Sub sunTest()
Dim i, k, kk, kkk, s, ss, sss, ssss, arr, lr, sp
Dim col1, col2, rv, d
Set d = CreateObject("scripting.dictionary")
arr = Sheets("数据源").Range("a1").CurrentRegion
For i = 3 To UBound(arr)
s = arr(i, 6)
If Not d.exists(s) Then
Set d(s) = CreateObject("scripting.dictionary")
End If
ss = arr(i, 15)
If ss = "分类其他" Or ss = "分类-2-a" Then
ss = "分类-2"
End If
If Not d(s).exists(ss) Then
Set d(s)(ss) = CreateObject("scripting.dictionary")
End If
sss = arr(i, 13) & "|" & arr(i, 16) & arr(i, 17)
If Not d(s)(ss).exists(sss) Then
Set d(s)(ss)(sss) = CreateObject("scripting.dictionary")
End If
ssss = arr(i, 14)
d(s)(ss)(sss)(ssss) = d(s)(ss)(sss)(ssss) + Val(arr(i, 18))
Next i
For Each k In d.keys
Sheets("模板").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = k
lr = .Cells(Rows.Count, 1).End(3).Row
.Range("a3") = .Range("a3").Value & "(" & k & ")"
For Each kk In d(k).keys
For i = 1 To lr
If InStr(.Cells(i, 1), kk) Then Exit For

Next i
If i = 3 Then
coll = 12: col2 = 14: w = 15
ElseIf i = 20 Then
col1 = 13: cl2 = 15: rw = 32
Else
col1 = 8: col2 = 11: rv = 45
End If
r = i + 2
For Each kkk In d(k)(kk).keys
r = r + 1
sp = Split(kkk, "|")
.Cells(r, 1) = sp(0)
.Cells(r, 2) = sp(1)
'.Cells(r, col1) = d(k)(kk)(kkk)("收入")
'.Cells(r, col2) = d(k)(kk)(kkk)("支出")
.Cells(rv + Val(sp(0)), "E") = .Cells(ry + Val(sp(0)), "g") + .Cells(r, col1)
.Cells(rv + Val(sp(0)), "I") = .Cells(rv + Val(sp(0)), "I") + Cells(r, col2)
Next kkk
Next kk

End With
Next k
Set d = Nothing
End Sub

h2016

yynrzwh 发表于 2023-12-13 10:04

基础不牢大佬您的变量  ss，有三种分类的哦，

蓝桥玄霜

楼主抄错了不少，如：rw -rv  w，col1-coll，col2-cl2
改好之后即可。

yynrzwh

昨天论坛似乎有点问题
用字典嵌套生成每家上市公司分类的收入.rar (35.76 KB, 下载次数: 9)

2023-12-14 09:46 上传

点击文件名下载附件

h2016

yynrzwh 发表于 2023-12-14 09:47
昨天论坛似乎有点问题

大佬就是rw=15，rw=32等
但是内容超过了15行，想把多的都放在15行上怎么办

h2016

结合上面例子大家可能对字典嵌套就有一个直观的理解了，给两朵花哈哈
Sub TestSub()
    Dim i, k, kk, kkk, s, ss, sss, ssss, arr, lr, sp
    Dim col1, col2, rw, d
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("数据源").Range("a1").CurrentRegion
        For i = 3 To UBound(arr)
            s = arr(i, 6)
            If Not d.exists(s) Then
                Set d(s) = CreateObject("scripting.dictionary")
            End If
            ss = arr(i, 15)
            If ss = "分类其他" Or ss = "分类-2-a" Then
                ss = "分类-2"
            End If
            If Not d(s).exists(ss) Then
                Set d(s)(ss) = CreateObject("scripting.dictionary")
            End If
            sss = arr(i, 13) & "|" & arr(i, 16) & arr(i, 17)
            If Not d(s)(ss).exists(sss) Then
                Set d(s)(ss)(sss) = CreateObject("scripting.dictionary")
            End If
            ssss = arr(i, 14)
            d(s)(ss)(sss)(ssss) = d(s)(ss)(sss)(ssss) + Val(arr(i, 18))
        Next i
Dim key1 As Variant
    Dim key2 As Variant
    Dim key3 As Variant
    Dim key4 As Variant
   
    Dim ws As Worksheet
    Set ws = Sheets("字典数值查看")
   
    ws.UsedRange.Clear
    ws.Range("2:10000").NumberFormat = "@"
   
    Dim rowNum As Long
    rowNum = 2
   
    For Each key1 In d.keys
        ws.Cells(rowNum, 1) = key1
        
        For Each key2 In d(key1).keys
            ws.Cells(rowNum, 2) = key2
            
            For Each key3 In d(key1)(key2).keys
                ws.Cells(rowNum, 3) = key3
               
                For Each key4 In d(key1)(key2)(key3).keys
                    ws.Cells(rowNum, 4) = key4
                    ws.Cells(rowNum, 5) = d(key1)(key2)(key3)(key4)
                    
                    rowNum = rowNum + 1
                Next key4
            Next key3
        Next key2
    Next key1
End Sub

h2016

yynrzwh 发表于 2023-12-14 09:47
昨天论坛似乎有点问题

您好，我用的是另外一个表创建的字典，要如和你这个字典关联上呢？

h2016

yynrzwh 发表于 2023-12-13 16:45

您好，我在这个代码前面就创建了字典d，要怎么和你这个代码的字典d关联啊
        Application.ScreenUpdating = True
    Dim d As Object, dc As Object
    Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(br)
If Trim(br(i, 9)) <> "" Then
            d(Trim(br(i, 9))) = ""  '所有市公司编号装入字典
           
        End If
    Next i

h2016

您好，我在这个代码前面就创建了字典d，要怎么和你这个代码的字典d关联啊
        Application.ScreenUpdating = True
    Dim d As Object, dc As Object
    Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(br)
If Trim(br(i, 9)) <> "" Then
            d(Trim(br(i, 9))) = ""  '所有市公司编号装入字典
           
        End If
    Next i