Option Explicit
Sub Ton()
Dim i&, j&, Lr&, t&, k&
Dim Arr(), KQ(), LuyKeNhap(), LuyKeXuat()
Dim Dic As Object, Key
Dim Sh As Worksheet
Dim sDay, eDay
Set Sh = Sheets("BanhKH")
sDay = Sh.[N2].Value: eDay = Sh.[Q2].Value
Set Dic = CreateObject("Scripting.Dictionary")
Lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Arr = Sh.Range("A4:H" & Lr).Value
ReDim KQ(1 To UBound(Arr), 1 To 7)
ReDim LuyKeNhap(1 To UBound(Arr), 1 To 1)
ReDim LuyKeXuat(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
Key = Arr(i, 3) & "#" & Arr(i, 4) & "#" & Arr(i, 5)
If Not Dic.Exists(Key) Then
t = t + 1: Dic.Add (Key), t
KQ(t, 1) = Arr(i, 3): KQ(t, 2) = Arr(i, 4): KQ(t, 3) = Arr(i, 5)
'-----phân tính tôn kho trươc ngày đa ghi ơ ô N2
If Arr(i, 2) < sDay Then
If Arr(i, 6) Like "Nh?p" Then LuyKeNhap(t, 1) = Arr(i, 7)
If Arr(i, 6) Like "Xu?t" Then LuyKeXuat(t, 1) = Arr(i, 7)
KQ(t, 4) = (LuyKeNhap(t, 1) - LuyKeXuat(t, 1))
End If
'------phan tinh phát sinh trong khoang tu N2 đên Q2
If (Arr(i, 2) >= sDay Or Arr(i, 2) <= eDay) And Arr(i, 6) Like "Nh?p" Then KQ(t, 5) = Arr(i, 7)
If Arr(i, 2) <= eDay And Arr(i, 6) Like "Xu?t" Then KQ(t, 6) = Arr(i, 7)
'------Tinh tôn trong ngay theo Mahang, khách hàng,
KQ(t, 7) = KQ(t, 4) + KQ(t, 5) - KQ(t, 6)
Else
k = Dic.Item(Key)
If Arr(i, 2) < sDay Then
If Arr(i, 6) Like "Nh?p" Then LuyKeNhap(k, 1) = LuyKeNhap(k, 1) + Arr(i, 7)
If Arr(i, 6) Like "Xu?t" Then LuyKeXuat(k, 1) = LuyKeXuat(k, 1) + Arr(i, 7)
KQ(k, 4) = KQ(k, 4) + (LuyKeNhap(k, 1) - LuyKeXuat(k, 1))
End If
If (Arr(i, 2) >= sDay Or Arr(i, 2) <= eDay) And Arr(i, 6) Like "Nh?p" Then KQ(k, 5) = KQ(k, 5) + Arr(i, 7)
If Arr(i, 2) <= eDay And Arr(i, 6) Like "Xu?t" Then KQ(k, 6) = KQ(k, 6) + Arr(i, 7)
KQ(k, 7) = KQ(k, 4) + KQ(k, 5) - KQ(k, 6)
End If
Next i
If t Then
Sh.Range("K15").Resize(10000, 7).ClearContents
Sh.Range("K15").Resize(t, 7) = KQ
End If
Set Dic = Nothing
MsgBox " Thành công"
End Sub
