数值和文本内容同时分类汇总

毛炜圣

如图所示，分别根据source，TARGET两列分类汇总求和weight数值、汇总WS文本（能分类计数更好）。最后效果如右边所示。

毛炜圣

右图 第一行和第三行也应合并为香港一行

毛炜圣

rarnma

这个工作用power query就只是点几下鼠标的事,请确保使用带有power query的excel版本(2016以上最好).在原表格区域向下加入新信息,右键点击结果区域选择刷新可将自动处理好新信息.

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim d As Object
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Set d = CreateObject("scripting.dictionary")
With Sheet1
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:f" & r)
    ReDim arr(1 To UBound(ar), 1 To 4)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) <> "" And Trim(ar(i, 4)) <> "" Then
            zf = Trim(ar(i, 3)) & "|" & Trim(ar(i, 4))
            t = d(zf)
            If t = "" Then
                k = k + 1
                d(zf) = k
                t = k
                arr(k, 1) = ar(i, 3)
                arr(k, 2) = ar(i, 4)
            End If
            arr(t, 3) = arr(t, 3) + ar(i, 5)
            If arr(t, 4) = "" Then
                arr(t, 4) = ar(i, 6)
            Else
               arr(t, 4) = arr(t, 4) & ";" & ar(i, 6)
            End If
        End If
    Next i
    rs = .Cells(Rows.Count, 8).End(xlUp).Row
    If rs > 1 Then .Range("h2:k" & rs) = Empty
    .[h2].Resize(k, 4) = arr
End With
MsgBox "Ok!"
End Sub

3190496160

新建 XLS 工作表.rar (56.87 KB, 下载次数: 2)

2021-9-6 08:11 上传

点击文件名下载附件

毛炜圣

3190496160 发表于 2021-9-6 08:11

感恩 好人一生平安

指月山人

rarnma 发表于 2021-9-5 22:15
这个工作用power query就只是点几下鼠标的事,请确保使用带有power query的excel版本(2016以上最好).在原表 ...

但愿他用的不是WPS

rarnma

指月山人 发表于 2021-9-6 16:11
但愿他用的不是WPS

大概率是啊