使用VBA编号及汇总统计

write123

求助问题：
1、表sheet1中“编号+项目大类”相同的编号一样，已用公式表示；
2、表sheet2中需要对sheet1数据进行汇总统计，并不需要项目细分的名称，主要是统计有几个细分项目及它的记分。汇总统计类似透视表，但是实际中细分项很多，用透视表会特别长。
谢谢各位老师！

3190496160

总体是个数组+字典的问题，但是，由于有小计，就比较麻烦，

3190496160

Sub 统计()
Dim d As Object
Dim ar As Variant
Dim br()
Dim i As Integer
Set d = CreateObject("scripting.dictionary")
With Sheet1
    r = .Cells(Rows.Count, 2).End(xlUp).Row
     .Range("b3:g" & r).Sort Key1:=.Range("e3"), Order1:=xlAscending
    ar = .Range("b3:g" & r)
End With
ReDim br(1 To UBound(ar), 1 To UBound(ar) * 2)
br(1, 1) = "序号": br(1, 2) = "姓名": br(1, 3) = "编号"
k = 2: y = 3
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        t = d(Trim(ar(i, 2)))
        If t = "" Then
            k = k + 1
            d(Trim(ar(i, 2))) = k
            t = k
            br(k, 1) = k - 2
            br(k, 2) = ar(i, 1)
            br(k, 3) = ar(i, 2)
        End If
        zf = Trim(ar(i, 4)) & "|" & Trim(ar(i, 5))
        If Not d.exists(zf) Then
            y = y + 1
            br(1, y) = ar(i, 4)
            br(2, y) = ar(i, 5)
            br(t, y) = ar(i, 6)
            d(zf) = y
        ElseIf Not d(zf) Then
            m = d(zf)
            br(t, m) = br(t, m) + ar(i, 6)
        End If
    End If
Next i
With Sheets("统计")
    .UsedRange.Clear
    .[a1].Resize(k, y) = br
    .[a1].Resize(k, y).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160

没有考虑小计的情况，仅供参考
求助示例.rar (19.64 KB, 下载次数: 16)

2020-12-2 15:45 上传

点击文件名下载附件

write123

3190496160 发表于 2020-12-2 15:45
没有考虑小计的情况，仅供参考

感谢您的解答！可能我表达有误，数据表sheet1中，只要有细分项，在“统计”表中依次往后排（有的人大项中可能有多个小项，有的只有1项，只有一项的就排在第一个，不用对应名称）再次上传附件，麻烦您再看下。

3190496160

write123 发表于 2020-12-2 16:46
感谢您的解答！可能我表达有误，数据表sheet1中，只要有细分项，在“统计”表中依次往后排（有的人大项中 ...

目前的代码已经能够实现你需要的效果了呀，只是表头的结构跟你原来的不同而已了，不明白你还需要什么？？
况且，现在上传的附件表格结构跟1楼的根本不一致嘛