同类项合并，数量汇总，数据量较大，求助！！！！

powerremain

longwin 发表于 2024-6-30 15:16
Sub test()
Set d = CreateObject("scripting.dictionary")
l = 3

老师，不改格式 怎么实现

longwin

powerremain 发表于 2024-6-30 20:27
老师，不改格式 怎么实现

具体情况说一下，或者传个附件说明

powerremain

longwin 发表于 2024-6-30 20:36
具体情况说一下，或者传个附件说明

就是除了G列数字求和汇总外，其他的列内容可能会是逻辑值，数组整体赋值后,格式就变了，变成value了。只是G列数字求和，别的列不变格式，只去重

longwin

powerremain 发表于 2024-6-30 21:52
就是除了G列数字求和汇总外，其他的列内容可能会是逻辑值，数组整体赋值后,格式就变了，变成value了。只 ...

产品名称+产品型号+单位，数量（求和），其它的不变，这样？

longwin

Set d = CreateObject("scripting.dictionary")
l = 3
Do
l1 = Cells(l, 1).End(xlDown).Row + 1
If Cells(l1 - 1, 1) = "*" Or Cells(l1 - 1, 1) = "" Then Exit Do
l2 = Cells(l, 1).End(xlDown).End(xlDown).Row - 1
arr = Range("D" & l1 & ":G" & l2)
For i = 1 To UBound(arr)
    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    d(s) = d(s) + arr(i, 4)
Next
ReDim brr(1 To d.Count, 1 To 4)
m = 0
For Each Key In d
    m = m + 1
    brr(m, 1) = Split(Key, "|")(0)
    brr(m, 2) = Split(Key, "|")(1)
    brr(m, 3) = Split(Key, "|")(2)
    brr(m, 4) = d(Key)
Next
Range("D" & l1 & ":G" & l1 + m - 1) = brr
If l2 > l1 + m - 1 Then
Rows(m + l1 & ":" & l2).Delete
End If
d.RemoveAll
l = l1 + m
Loop
End Sub

powerremain

9楼的效果
就是  产品名称+产品型号+单位这些数据会有逻辑值公式，现在您这个数据回来逻辑值都没有了，因为被数组赋值一遍。数量是要求和的

powerremain

longwin 发表于 2024-6-30 22:51
产品名称+产品型号+单位，数量（求和），其它的不变，这样？

如9楼效果，（产品名称+产品型号+单位）实际使用数据会有公式是逻辑值，数组赋值后变成VALUE了，这几个不变
数量（求和）

准提部林

powerremain 发表于 2024-6-30 23:43
如9楼效果，（产品名称+产品型号+单位）实际使用数据会有公式是逻辑值，数组赋值后变成VALUE了，这几个不 ...

9樓的方式挺好的,
還有問題???

涉及保留格式及刪行, 用純數組不適宜\\

准提部林

powerremain 发表于 2024-6-30 23:43
如9楼效果，（产品名称+产品型号+单位）实际使用数据会有公式是逻辑值，数组赋值后变成VALUE了，这几个不 ...

同一產品型號, 應不會有不同品名及不同單位吧!!!
單一條件匯總即可!!

powerremain

准提部林 发表于 2024-7-1 11:57
同一產品型號, 應不會有不同品名及不同單位吧!!!
單一條件匯總即可!!

9楼的结果是错误的
Sub text2()
Dim arr, d As Object
Set d = VBA.CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = UBound(arr) To 4 Step -1
    If arr(i, 4) = "总计" Then d(arr(i, 4)) = d(arr(i, 4)) & " " & i
Next
s = Split(d("总计"), " ")
For r = 1 To UBound(s)
    If r = UBound(s) Then
       fr = 4
    Else
       fr = s(r + 1)
    End If
    er = s(r)
    d.RemoveAll
    Set unrng = Rows(5000)
    For i = fr To er
        If Cells(i, 4).Value = "" Then Exit For
        If Cells(i, 5).Value <> "" Then
           If Not d.exists(Cells(i, 5).Value) Then
              d(Cells(i, 5).Value) = i
           Else
              y = d(Cells(i, 5).Value)
              Cells(y, 7).Value = Cells(y, 7).Value + Cells(i, 7).Value
              Cells(y, 9).Value = Cells(y, 9).Value + Cells(i, 9).Value
              Set unrng = Union(unrng, Rows(i))
           End If
        End If
    Next
    unrng.EntireRow.Delete
Next
Set d = Nothing
End Sub