字典-分类汇总

jjmysjg

romecyf 发表于 2024-10-30 23:29
Sub test()
Dim dic, arr(), i, j, k, s, ss
Set dic = CreateObject("scripting.dictionary")

运行没反应。

Again123456

沧海一粟123123

Sub test()
Dim arr
Dim i, j, k As Integer
Dim d As New Dictionary
Dim x, y As Integer
Dim brr(1 To 50, 1 To 3)
Dim crr

k = Range("b65536").End(xlUp).Row
arr = Range("b2:d" & k)
For x = 1 To UBound(arr)
    If Not d.Exists(arr(x, 1)) Then
        i = i + 1
        d(arr(x, 1)) = i
        brr(i, 1) = arr(x, 1)
        brr(i, 2) = arr(x, 2)
        brr(i, 3) = arr(x, 3)
    Else
        j = d(arr(x, 1))
        brr(j, 2) = brr(j, 2) & "," & arr(x, 2)
        brr(j, 3) = brr(j, 3) + arr(x, 3)
    End If
Next x
d.RemoveAll
For x = 1 To UBound(brr)
    crr = Split(brr(x, 2), ",")
    For y = 0 To UBound(crr)
        d(crr(y)) = ""
    Next y
    brr(x, 2) = Join(d.Keys, ",")
    d.RemoveAll
    Erase crr
Next x
Range("f2").Resize(UBound(brr), 3) = brr
End Sub

铁马1980

JSA练手

ericxzhou

Python+Pandas:
import pandas as pd

df = pd.read_excel('pandas exercise/sample543.xlsx', usecols='a:d')
df.groupby('姓名').agg({'类别': lambda x: ','.join(x.unique()), '成绩': sum})

翁知江安

Sub huizong1()
Dim i, j, k, m
Dim nostr As String
Dim arr, brr, crr
Dim d1 As Object
Dim d2 As Object
Dim d3 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Sheet1.Range("f6:h12").Clear
arr = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(arr)
    d1(arr(i, 2)) = d1(arr(i, 2)) + arr(i, 4)
    d2(arr(i, 2) & "," & arr(i, 3)) = ""
Next
ReDim crr(1 To UBound(arr), 1 To 2)
For Each k In d2.keys
   nostr = k
   brr = Split(nostr, ",")
   m = m + 1
   crr(m, 1) = Split(nostr, ",")(0)
   crr(m, 2) = Split(nostr, ",")(1)
   If Not d3.exists(crr(m, 1)) Then
   d3(crr(m, 1)) = crr(m, 2)
      Else
      d3(crr(m, 1)) = d3(crr(m, 1)) & "," & crr(m, 2)
    End If
Next
Sheet1.[f1].Resize(1, 3).Copy Sheet1.[f6]
Sheet1.[f7].Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.keys)
Sheet1.[h7].Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.items)
Sheet1.[g7].Resize(d3.Count, 1) = Application.WorksheetFunction.Transpose(d3.items)

End Sub

供参考

wanghui834

直接表格函数做的公式就可以完成，不需要vba这么麻烦

lizhipei78

Again123456 发表于 2024-11-1 10:35

这么多人，我也来玩一下

Again123456

lizhipei78 发表于 2024-11-2 19:52
这么多人，我也来玩一下

哦，我没注意多了个逗号，稍改一下就行了

yangqianming

Again123456 发表于 2024-11-2 20:22
哦，我没注意多了个逗号，稍改一下就行了

有点儿不明白，reduce第二参数是个数组，p??=p.push([b,c,0])-1是第一次见到p就把b,c,0添加到数组，后面又p[p][1]+=p[p][1].includes(c)?'':','+c,//三步运算
p[p][2]+=d,不知道是不是p[行号][列]的意思，不明白了。