|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 查询()
Dim i, s, t, p As Integer
Dim m, n As Date
Dim ar, br, cr As Variant
Dim d1, d2, d3, d4 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
m = IIf(Sheets("汇总表").[i1] = "", #1/1/1900#, Sheets("汇总表").[i1])
n = IIf(Sheets("汇总表").[i2] = "", #1/1/1900#, Sheets("汇总表").[i2])
ar = Sheets("进出库明细").[a1].CurrentRegion
ReDim br(1 To UBound(ar) * 2, 1 To 4)
For i = 3 To UBound(ar)
If ar(i, 1) < m Then
If Len(ar(i, 7)) * Len(ar(i, 8)) > 0 Then
d2(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) = d2(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) + ar(i, 6)
If Not d3.exists(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) Then
d3(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) = 0
t = t + 1
For p = 1 To 2
br(t, p) = ar(i, p + 1)
Next
For p = 3 To 4
br(t, p) = ar(i, p + 4)
Next
End If
End If
If Len(ar(i, 10)) * Len(ar(i, 11)) > 0 Then
d2(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) = d2(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) - ar(i, 9)
If Not d3.exists(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) Then
d3(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) = 0
t = t + 1
For p = 1 To 2
br(t, p) = ar(i, p + 1)
Next
For p = 3 To 4
br(t, p) = ar(i, p + 7)
Next
End If
End If
End If
If ar(i, 1) >= m And ar(i, 1) <= n Then
If Len(ar(i, 7)) * Len(ar(i, 8)) > 0 Then
If Not d3.exists(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) Then
d3(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) = ar(i, 6)
t = t + 1
For p = 1 To 2
br(t, p) = ar(i, p + 1)
Next
For p = 3 To 4
br(t, p) = ar(i, p + 4)
Next
Else
d3(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) = d3(ar(i, 2) & ar(i, 3) & ar(i, 7) & ar(i, 8)) + ar(i, 6)
End If
End If
If Len(ar(i, 10)) * Len(ar(i, 11)) > 0 Then
If Not d3.exists(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) Then
t = t + 1
For p = 1 To 2
br(t, p) = ar(i, p + 1)
Next
For p = 3 To 4
br(t, p) = ar(i, p + 7)
Next
End If
If Not d4.exists(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) Then
d4(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) = ar(i, 9)
Else
d4(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11)) = ar(i, 9) + d4(ar(i, 2) & ar(i, 3) & ar(i, 10) & ar(i, 11))
End If
End If
End If
Next
With Sheets("汇总表")
cr = .[a1].CurrentRegion
.[a4].Resize(50, UBound(cr, 2)).ClearContents
.[a4].Resize(50, UBound(cr, 2)).ClearFormats
If t > 0 Then
.[b4].Resize(t, 4) = br
End If
.[b3].Select
.[b3].Resize(t + 1, 4).Sort key1:=Columns("b"), order1:=xlAscending, Header:=xlYes, key2:=Columns("c"), order2:=xlAscending, Header:=xlYes
.[b3].Select
cr = .[a1].CurrentRegion
For i = 4 To t + 3
d1(cr(i, 2) & cr(i, 3)) = d1(cr(i, 2) & cr(i, 3)) + 1
.Cells(i, 8) = IIf(d3(cr(i, 2) & cr(i, 3) & cr(i, 4) & cr(i, 5)) = "", 0, d3(cr(i, 2) & cr(i, 3) & cr(i, 4) & cr(i, 5)))
.Cells(i, 9) = IIf(d4(cr(i, 2) & cr(i, 3) & cr(i, 4) & cr(i, 5)) = "", 0, d4(cr(i, 2) & cr(i, 3) & cr(i, 4) & cr(i, 5)))
.Cells(i, 6) = .Cells(i, 8) - .Cells(i, 9) + d2(cr(i, 2) & cr(i, 3) & cr(i, 4) & cr(i, 5))
If i = 4 Then
.Cells(i, 1) = 1
Else
If cr(i, 2) = cr(i - 1, 2) And cr(i, 3) = cr(i - 1, 3) Then
.Cells(i, 1) = .Cells(i - 1, 1)
.Cells(i, 2) = "": .Cells(i, 3) = ""
Else
.Cells(i, 1) = .Cells(i - 1, 1) + 1
End If
End If
Next
For i = 4 To t + 3
s = IIf(d1(.Cells(i, 2).Value & .Cells(i, 3).Value) = "", 0, d1(.Cells(i, 2).Value & .Cells(i, 3).Value))
If s > 1 Then
.Cells(i, 7) = WorksheetFunction.Sum(.Cells(i, 6).Resize(s, 1))
If .Cells(i, 7) > 0 Then
For p = 1 To 3
.Cells(i, p).Resize(s, 1).Merge
Next
.Cells(i, 7).Resize(s, 1).Merge
Else
.Cells(i, 1).Resize(s, 10).ClearContents
End If
Else
.Cells(i, 7) = .Cells(i, 6)
If .Cells(i, 7) = 0 Then
.Cells(i, 1).Rows(i).ClearContents
End If
End If
Next
For i = t + 3 To 4 Step -1
If .Cells(i, 4) = "" Then
.Cells(i, 4).EntireRow.Delete
End If
Next
irow = .[d65536].End(xlUp).Row
.Cells(irow + 1, 1) = "合计"
.Cells(irow + 1, 1).Resize(1, 6).Merge
.Cells(irow + 1, 7) = WorksheetFunction.Sum(.Cells(4, 6).Resize(irow - 3, 1))
.Cells(irow + 1, 8) = WorksheetFunction.Sum(.Cells(4, 8).Resize(irow - 3, 1))
.Cells(irow + 1, 9) = WorksheetFunction.Sum(.Cells(4, 9).Resize(irow - 3, 1))
.[a4].Resize(irow - 2, 10).Borders.LineStyle = 1
.[a4].Resize(irow - 2, 10).HorizontalAlignment = xlCenter
.[a4].Resize(irow - 2, 10).VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub |
|