请教分类汇总的问题！

lushang2018 · 发表于 2023-2-5 22:00

Sub 测试() ''答题专用套路--by:学习使我快乐
Dim i, j, k, m, n, arr, brr, crr, drr
Dim sht As Worksheet, wbk As Workbook, rng As Range
Dim dic As Object, key As String, keys, items
Set dic = CreateObject("scripting.dictionary")
arr = Sheet4.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
key = arr(i, 1)
dic(key) = dic(key) & "," & i
Next
keys = dic.keys
items = dic.items
For i = LBound(keys) To UBound(keys)
Cells(2 + i, "G") = "'" & keys(i)
Cells(2 + i, "H").Resize(1, 3) = 合并(items(i), arr)
Next
Set rng = Range("G1").CurrentRegion
rng.Sort key1:=rng.Range("A1"), order1:=xlAscending, Header:=xlYes
End Sub
Function 合并(items, arr)
Dim i, brr, s1, s2, s3, 原始行号
Dim dic1 As Object
Set dic1 = CreateObject("scripting.dictionary")
Dim dic2 As Object
Set dic2 = CreateObject("scripting.dictionary")
Dim dic3 As Object
Set dic3 = CreateObject("scripting.dictionary")
brr = Split(items, ",")
For i = 1 To UBound(brr)
原始行号 = brr(i)
dic1(arr(原始行号, 3)) = dic1(arr(原始行号, 3)) + 1
dic2(arr(原始行号, 4)) = dic2(arr(原始行号, 4)) + 1
dic3(arr(原始行号, 5)) = dic3(arr(原始行号, 5)) + 1
Next
For i = 1 To dic1.Count
s1 = s1 & "-" & dic1.keys()(i - 1) & dic1.items()(i - 1)
Next
For i = 1 To dic2.Count
s2 = s2 & "-" & dic2.keys()(i - 1) & dic2.items()(i - 1)
Next
For i = 1 To dic3.Count
s3 = s3 & "-" & dic3.keys()(i - 1) & dic3.items()(i - 1)
Next
ReDim crr(1 To 3)
crr(1) = Mid(s1, 2)
crr(2) = Mid(s2, 2)
crr(3) = Mid(s3, 2)
合并 = crr
End Function

复制代码

iqin80 · 发表于 2023-2-5 22:18

cjc209 发表于 2023-2-5 18:07
就是利用循环加字典顺利完成

非常感谢您的帮助！

iqin80 · 发表于 2023-2-5 22:20

lushang2018 发表于 2023-2-5 21:59

就是就是，最好能排序！

iqin80 · 发表于 2023-2-5 22:21

cjc209 发表于 2023-2-5 18:07
就是利用循环加字典顺利完成

写得太详细了，再次感谢！

liulang0808 · 发表于 2023-2-6 08:13

Sub testg()
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
For j = 2 To UBound(arr)
      For i = 3 To 5
         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))(Asc(arr(j, i))) = d(arr(j, 1) & arr(1, i))(Asc(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 w = 1 To d(arr(j, 7) & arr(1, i)).Count
                  k = WorksheetFunction.Small(d(arr(j, 7) & arr(1, i)).keys, w)
                  str1 = str1 & "-" & Chr(k) & d(arr(j, 7) & arr(1, i))(k)
            Next w
            arr(j, i) = Mid(str1, 2)
         Next i
      End If
Next j
ActiveSheet.UsedRange = arr
End Sub

liulang0808 · 发表于 2023-2-6 08:14

附件内容供参考。。。。。

mmwwdd · 发表于 2023-2-6 08:19

呵呵,楼主说要把A放在前面

准提部林 · 发表于 2023-2-6 22:00

自訂排序//
A/B/C/D...也可換成甲/乙/丙/丁....

Xl0000460-1.rar (29.42 KB, 下载次数: 11)

iqin80 · 发表于 2023-2-6 22:05

准提部林发表于 2023-2-6 22:00
自訂排序//
A/B/C/D...也可換成甲/乙/丙/丁....

方法很巧妙，学习了，谢谢帮助！

iqin80 · 发表于 2023-2-6 22:07

liulang0808 发表于 2023-2-6 08:14
附件内容供参考。。。。。

感谢帮助，受益匪浅！

		自动登录	找回密码
密码			免费注册

[求助] 请教分类汇总的问题！

评分

评分

评分

点评

评分