请教分类汇总的问题！

iqin80

想达到这样的效果：分类统计满足两个条件的数据，主要是最终的数据写入格式比较特殊，请求大佬的帮助，谢谢！

liulang0808

Sub testg()
    Set d = CreateObject("scripting.dictionary")
    arr = ActiveSheet.UsedRange
    For j = 2 To UBound(arr)
        For i = 3 To 6
            If Not d.exists(arr(j, 1) & arr(1, i)) Then
                Set d(arr(j, 1) & arr(1, i)) = CreateObject("scripting.dictionary")
            End If
            d(arr(j, 1) & arr(1, i))(arr(j, i)) = d(arr(j, 1) & arr(1, i))(arr(j, i)) + 1
        Next i
    Next j
    For j = 2 To UBound(arr)
        If Len(arr(j, 7)) > 0 Then
            For i = 8 To 10
                str1 = ""
                For Each k In d(arr(j, 7) & arr(1, i)).keys
                    str1 = str1 & "-" & k & d(arr(j, 7) & arr(1, i))(k)
                Next k
                arr(j, i) = Mid(str1, 2)
            Next i
        End If
    Next j
    ActiveSheet.UsedRange = arr
End Sub

liulang0808

供参考。。。。。

准提部林

選項有幾种?? ABCDE*
要排序??

iqin80

准提部林 发表于 2023-2-5 11:42
選項有幾种?? ABCDE*
要排序??

是的，有可能这种情况，谢谢

cjc209

请问A4是不是表示A出现4次?

cjc209

如果是那样 就好整 我是
Sub 二级字典嵌套()
    Dim brr()
    arr = Sheet4.Range("A1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 4)
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    For i1 = 3 To 5
        For i = 2 To UBound(arr)
            关键字1 = arr(i, 1) & ""
            关键字2 = arr(i, i1) & ""
            If Not dic.exists(关键字1) Then
                Set dic(关键字1) = CreateObject("scripting.dictionary") '二级字典对象建立 对象必须用Set 或者报错
            End If
            dic(关键字1)(关键字2) = dic(关键字1)(关键字2) + 1 '终级计数
        Next
        '    最大列数 = 0
        m = dic.Count
        For i = 0 To dic.Count - 1
            一级字典键值 = dic.keys()(i) '循环出一级字典键值
            brr(i + 1, 1) = 一级字典键值 '一级字典键值写入对应数组位置
            '        最大列数 = Application.Max(最大列数, dic(一级字典键值).Count) '取得需要的最大列
            二级字典键值数组 = dic(一级字典键值).keys
            二级字典值数组 = dic(一级字典键值).items
            For k = 0 To UBound(二级字典键值数组) '循环二级字典结果数组
                brr(i + 1, i1 - 1) = brr(i + 1, i1 - 1) & "-" & 二级字典键值数组(k) & 二级字典值数组(k) '循环二级字典 取出二级字典的键值和对应的item值进行连接
            Next
            brr(i + 1, i1 - 1) = Mid(brr(i + 1, i1 - 1), 2)
        Next
        dic.RemoveAll
    Next
    Sheet4.Range("g2").Resize(m, 4) = brr
    Set dic = Nothing
End Sub

cjc209

答案 是不是这个意思

cjc209

就是利用循环加字典顺利完成

lushang2018