求助VBA去重复多条件汇总

GUANCHZH · 发表于 2023-1-29 22:15

根据工作表"送货单数据表"的C列到F列，4列数据除去重复。然后将工I列的数量根据U列的出入库类别，分别汇总入库数量和汇总出库数量。并增加一列库存数量：等于入库减出库。也就是要工作表"库存表"这个效果。其实这个也就是透视表的功能，不过用透视表数据多了，运行非常慢。所以求助vba代码实现。

VBA去重复多条件汇总.rar (16.36 KB, 下载次数: 17)

chzsh · 发表于 2023-1-30 07:55

本帖最后由 chzsh 于 2023-1-30 17:26 编辑

VBA去重复多条件汇总

chzsh · 发表于 2023-1-30 07:56

本帖最后由 chzsh 于 2023-1-30 16:34 编辑

VBA去重复多条件汇总

liulang0808 · 发表于 2023-1-30 08:11

Sub 按钮1_Click()
Set d = CreateObject("scripting.dictionary")
Sheets("送货单数据表").[a1] = 1
arr = Sheets("送货单数据表").UsedRange
r = 0
For j = 4 To UBound(arr)
      str1 = arr(j, 3) & arr(j, 4) & arr(j, 5) & arr(j, 6)
      If Not d.exists(str1) Then
         r = r + 1
         d(str1) = r
         x = 0
         For Each i In Array(3, 4, 5, 7, 6)
            x = x + 1
            arr(r, x) = arr(j, i)
         Next i
         arr(j, 6) = 0
         arr(j, 7) = 0
         arr(j, 8) = 0
      End If
      If arr(j, 21) = "出库" Then
         arr(d(str1), 6) = Val(arr(d(str1), 6)) + Val(arr(j, 9))

      End If
      arr(d(str1), 8) = Val(arr(d(str1), 8)) + Val(arr(j, 9))
      arr(d(str1), 7) = Val(arr(d(str1), 8)) - Val(arr(d(str1), 6))
Next j
[a8].Resize(r, 8) = arr
Sheets("送货单数据表").[a1] = ""
End Sub

liulang0808 · 发表于 2023-1-30 08:13

供参考。。。。。

shiruiqiang · 发表于 2023-1-30 08:13

3190496160 · 发表于 2023-1-30 10:23

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("送货单数据表")
r = .Cells(Rows.Count, 3).End(xlUp).Row
If r < 4 Then MsgBox "送货单数据表为空！": End
ar = .Range("c3:u" & r)
End With
Dim br()
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" And Trim(ar(i, 4)) <> "" Then
      zd = Trim(ar(i, 1)) & "|" & Trim(ar(i, 2)) & "|" & Trim(ar(i, 3)) & "|" & Trim(ar(i, 4))
      t = d(zd)
      If t = "" Then
         k = k + 1
         d(zd) = k
         t = k
         For j = 1 To 5
            br(k, j) = ar(i, j)
         Next j
      End If
      If VBA.Trim(ar(i, 19)) = "入库" Then
         br(t, 6) = br(t, 6) + ar(i, 9)
      Else
         br(t, 7) = br(t, 7) + ar(i, 9)
      End If
      br(t, 8) = br(t, 6) - br(t, 7)
End If
Next i
With Sheets("库存表")
.[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
.[a1].CurrentRegion.Offset(2) = Empty
.[a3].Resize(k, UBound(br, 2)) = br
.[a3].Resize(k, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160 · 发表于 2023-1-30 10:23

3190496160 · 发表于 2023-1-30 10:24

VBA去重复多条件汇总.rar (25.15 KB, 下载次数: 12)

GUANCHZH · 发表于 2023-1-30 12:31

非常感谢各位老师的帮助

		自动登录	找回密码
密码			免费注册

[求助] 求助VBA去重复多条件汇总

评分

评分

评分

评分