提取表格内数据按要求显示

tofzhao

今铭昔 发表于 2022-6-26 20:27
错误是把所有的*1去除了，虽然解决了，但是使用字符串替换思路确实是不怎么高明，还是有一定的漏洞，仅供 ...

非常感谢～～～～～

lyfegf

不小心发重复了

lyfegf

Sub test_tp()
    Dim i&, R&, j&, y&, N&, m, x, Arr, Brr, obj, K, num As Double, ss
    Dim dFenzu As Object, key As String, dMx, arrjg
    Dim cTp As New Collection
    Set dFenzu = CreateObject("Scripting.Dictionary")
    Set dMx = CreateObject("Scripting.Dictionary")
    Arr = Range("a1").CurrentRegion.Value

    For i = 2 To UBound(Arr)
        key = Arr(i, 2) & "@" & Arr(i, 4)
        If dFenzu.Exists(key) = False Then Set dFenzu(key) = New Collection
        dFenzu(key).Add i  '记录分组行号
    Next

    ReDim arrjg(1 To dFenzu.Count + 1, 1 To 4) '定义结果数组
    For Each obj In dFenzu.keys
        Set cTp = dFenzu(obj) '每个key的行号集合
        N = N + 1: Brr = Split(obj, "@")
        arrjg(N, 1) = Brr(0): arrjg(N, 4) = Brr(1)
        dMx.RemoveAll   '先清空下字典
        For Each x In cTp  '对全部行循环
            num = Arr(x, 3) '输了
            arrjg(N, 2) = arrjg(N, 2) + num '数量合计
            dMx(num) = dMx(num) + 1 '重复输了计数
        Next
        ReDim Brr(dMx.Count - 1) '定义临时数组拼接明细
        K = 0
        For Each x In dMx.keys
            m = dMx(x)
            Select Case m
            Case 1  '1个的时候,直接写数字
                Brr(K) = x
            Case Else  '多个的时候,后面拼接个数量
                Brr(K) = x & "*" & m
            End Select
            K = K + 1 '临时数组下标
        Next
        '特殊的单独一个不显示
        ss = Join(Brr, "+")
        If Val(ss) <> ss Then arrjg(N, 3) = ss
    Next

    [i9].Resize(UBound(arrjg), 4) = arrjg
End Sub