数据汇总

CrAzyDentuso

把<数据源>中，商品编码、商品条码、商品名称、大类、大类编码一样的汇总成一行，然后把对应的差异数量和差异金额加起来，货架编码合并为之前对应行里的货架编码(差异数量)，谢谢各位大佬~~

汇总成结果1：


=================================================================================

把<数据源>中，商品编码、商品条码、商品名称、大类、大类编码一样的汇总成一行，然后把对应的差异数量和差异金额加起来，货架编码合并为之前对应行里的货架编码(差异数量)，然后把求出结果中差异金额为0的行删除(多了一个这个条件)，谢谢各位大佬~~

汇总成结果2：



工作簿1.zip (15.97 KB, 下载次数: 8)

2023-3-24 16:23 上传

点击文件名下载附件

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("数据源")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a1:v" & r)
End With
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar)
    If Trim(ar(i, 5)) <> "" Then
        zd = Trim(ar(i, 5)) & "|" & Trim(ar(i, 6)) & "|" & Trim(ar(i, 7)) & "|" & Trim(ar(i, 10)) & "|" & Trim(ar(i, 22))
        t = d(zd)
        If t = "" Then
            k = k + 1
            d(zd) = k
            t = k
            For j = 5 To 7
                br(k, j - 4) = ar(i, j)
            Next j
            br(k, 4) = ar(i, 10)
            br(k, 7) = ar(i, 22)
        End If
        br(t, 5) = br(t, 5) + Val(ar(i, 18))
        br(t, 6) = br(t, 6) + Val(ar(i, 19))
        If br(t, 8) = "" Then
            br(t, 8) = ar(i, 14) & "(" & ar(i, 18) & ")"
        Else
            br(t, 8) = br(t, 8) & " " & ar(i, 14) & "(" & ar(i, 18) & ")"
        End If
    End If
Next i
If k = "" Then MsgBox "没有数据！"
With Sheets("汇总")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(k, UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

工作簿1.rar (26.22 KB, 下载次数: 12)

2023-3-24 16:46 上传

点击文件名下载附件

CrAzyDentuso

3190496160 发表于 2023-3-24 16:46

感谢大佬，速度好快，还有2个小问题能否一起解决下~

1、能不能把M-58A-03(3.0000) M-94A-15(-3.0000)变成M-58A-03(3) M-94A-15(-3)，数据源是文本格式，我试了把他们转成数值格式，再点你那个按钮就可以，能否直接帮我加个代码

2、里面另一页中结果2一起写一下，就是把刚才求出结果中差异金额为0的行删除(多了一个这个条件)

selen

两个都帮你写了

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br(), cr()
Set d = CreateObject("scripting.dictionary")
With Sheets("数据源")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a1:v" & r)
End With
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar)
    If Trim(ar(i, 5)) <> "" Then
        zd = Trim(ar(i, 5)) & "|" & Trim(ar(i, 6)) & "|" & Trim(ar(i, 7)) & "|" & Trim(ar(i, 10)) & "|" & Trim(ar(i, 22))
        t = d(zd)
        If t = "" Then
            k = k + 1
            d(zd) = k
            t = k
            For j = 5 To 7
                br(k, j - 4) = ar(i, j)
            Next j
            br(k, 4) = ar(i, 10)
            br(k, 7) = ar(i, 22)
        End If
        br(t, 5) = br(t, 5) + Val(ar(i, 18))
        br(t, 6) = br(t, 6) + Val(ar(i, 19))
        If br(t, 8) = "" Then
            br(t, 8) = ar(i, 14) & "(" & Val(ar(i, 18)) & ")"
        Else
            br(t, 8) = br(t, 8) & " " & ar(i, 14) & "(" & Val(ar(i, 18)) & ")"
        End If
    End If
Next i
If k = "" Then MsgBox "没有数据！"
ReDim cr(1 To k, 1 To 8)
For i = 1 To k
    If Trim(br(i, 6)) <> "" Then
        If br(i, 6) <> 0 Then
            m = m + 1
            For j = 1 To 8
                cr(m, j) = br(i, j)
            Next j
        End If
    End If
Next i
With Sheets("汇总")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(k, UBound(br, 2)) = br
End With
With Sheets("汇总2")
    .[a1].CurrentRegion.Offset(1) = Empty
    If m <> "" Then .[a2].Resize(m, UBound(cr, 2)) = cr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

工作簿1.rar (27.4 KB, 下载次数: 12)

2023-3-24 17:32 上传

点击文件名下载附件

CrAzyDentuso

3190496160 发表于 2023-3-24 17:32

感谢大佬…

CrAzyDentuso

selen 发表于 2023-3-24 17:20
两个都帮你写了

感谢大佬……

全党

参与一下，看看是不是这个意思。用到dic.remove语句。

1. Sub 汇总()
   
2. Application.ScreenUpdating = False
   
3. 
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. arr = Sheets("数据源").Range("a1").CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.     If Trim(arr(i, 5)) <> "" Then
   
8.         Key = Trim(arr(i, 5)) & "," & Trim(arr(i, 6)) & "," & Trim(arr(i, 7)) _
   
9.         & "," & Trim(arr(i, 10)) & "," & Trim(arr(i, 22))
   
10.         If Not dic.exists(Key) Then
    
11.         dic(Key) = Array(arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 10), Val(arr(i, 18)), Val(arr(i, 19)), arr(i, 22), arr(i, 14))
    
12.         Else
    
13.         k1 = dic(Key)(4): k2 = dic(Key)(5): k3 = dic(Key)(7)
    
14.         dic(Key) = Array(arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 10), k1 + Val(arr(i, 18)), k2 + Val(arr(i, 19)), arr(i, 22), k3 & ";" & arr(i, 14))
    
15.         End If
    
16.     End If
    
17. Next
    
18. For Each ss In dic.keys
    
19. If dic(ss)(4) = 0 Then
    
20. dic.Remove (ss)
    
21. End If
    
22. Next
    
23. With Sheets("汇总2")
    
24.     .[a1].CurrentRegion.Offset(1) = Empty
    
25.     .[a2].Resize(dic.Count, 8) = Application.Rept(dic.items, 1)
    
26. End With
    
27. End Sub

复制代码