Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("入库登记")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "入库登记为空！": End
ar = .Range("a1:aa" & r)
End With
With Sheets("出库登记")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs < 2 Then MsgBox "出库登记为空！": End
br = .Range("a1:aa" & rs)
End With
ReDim arr(1 To UBound(ar) + UBound(br), 1 To 23)
With Sheets("收发存汇总")
ks = .[c2]
js = .[c3]
For i = 2 To UBound(ar)
If Trim(ar(i, 8)) <> "" And Trim(ar(i, 14)) <> "" And Trim(ar(i, 17)) <> "" Then
zd = Trim(ar(i, 8)) & "|" & Trim(ar(i, 14)) & "|" & Trim(ar(i, 17))
t = d(zd)
If t = "" Then
k = k + 1
d(zd) = k
t = k
For j = 8 To 12
arr(k, j - 7) = ar(i, j)
Next j
arr(k, 6) = ar(i, 14)
arr(k, 7) = ar(i, 17)
End If
If Trim(ar(i, 1)) <> "" Then
If IsDate(ar(i, 1)) Then
If ar(i, 1) >= ks And ar(i, 1) <= js Then
If Trim(ar(i, 6)) <> "调拨入库" Then
arr(t, 12) = arr(t, 12) + ar(i, 13)
arr(t, 13) = arr(t, 13) + ar(i, 18)
Else
arr(t, 14) = arr(t, 14) + ar(i, 13)
arr(t, 15) = arr(t, 15) + ar(i, 18)
End If
arr(t, 10) = arr(t, 12) + arr(t, 14)
arr(t, 11) = arr(t, 13) + arr(t, 15)
ElseIf ar(i, 1) < ks And ar(i, 1) > js Then
arr(t, 8) = arr(t, 8) + ar(i, 13)
arr(t, 9) = arr(t, 9) + ar(i, 18)
End If
End If
End If
End If
Next i
For i = 2 To UBound(br)
If Trim(br(i, 8)) <> "" And Trim(br(i, 16)) <> "" And Trim(br(i, 17)) <> "" Then
zd = Trim(br(i, 8)) & "|" & Trim(br(i, 16)) & "|" & Trim(br(i, 17))
t = d(zd)
If t = "" Then
k = k + 1
d(zd) = k
t = k
For j = 8 To 12
arr(k, j - 7) = br(i, j)
Next j
arr(k, 6) = br(i, 16)
arr(k, 7) = br(i, 17)
End If
If Trim(br(i, 1)) <> "" Then
If IsDate(br(i, 1)) Then
If br(i, 1) >= ks And br(i, 1) <= js Then
If Trim(br(i, 27)) = "发料出库" Then
arr(t, 18) = arr(t, 18) + br(i, 13)
arr(t, 19) = arr(t, 19) + br(i, 18)
Else
arr(t, 20) = arr(t, 20) + br(i, 13)
arr(t, 21) = arr(t, 21) + br(i, 18)
End If
arr(t, 16) = arr(t, 18) + arr(t, 20)
arr(t, 17) = arr(t, 19) + arr(t, 21)
ElseIf ar(i, 1) < ks And ar(i, 1) > js Then
arr(t, 8) = arr(t, 8) - br(i, 13)
arr(t, 9) = arr(t, 9) - br(i, 18)
End If
End If
End If
End If
Next i
.UsedRange.Offset(8).Borders.LineStyle = 0
.UsedRange.Offset(8) = Empty
.[b9].Resize(k, UBound(arr, 2)) = arr
.[b9].Resize(k, UBound(arr, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-7-1 19:35
楼主
