Dữ liệu nhập xuất phải theo thứ tự thời gian
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$2" Then Call ChiTiet(Target.Value)
End SubOption Explicit
Dim b(0 To 3000, 1 To 6) 'Gioi han 3000 dong ket qua cua tung Phan Xuong
Dim dic As Object, aNhap(), aXuat(), a(), fDay As Date, ngay As Date
Dim srNhap&, srXuat&, rN&, rX&, r&, t&, F&, k&
Sub ChiTiet(MaSP)
Dim aTon(), res(), i&, j&, sR&, tong#
Set dic = CreateObject("Scripting.Dictionary")
On Error Resume Next
Sheets("Nhap").ShowAllData
Sheets("Xuat").ShowAllData
On Error GoTo 0
With Sheets("TonDau")
aTon = .Range("D3", .Range("L" & Rows.Count).End(xlUp)).Value
fDay = .Range("E1").Value
End With
With Sheets("Nhap")
aNhap = .Range("A3", .Range("N" & Rows.Count).End(xlUp)).Value
srNhap = UBound(aNhap)
End With
With Sheets("Xuat")
aXuat = .Range("C3", .Range("Q" & Rows.Count).End(xlUp)).Value
srXuat = UBound(aXuat)
End With
F = 0
For i = 1 To UBound(aTon)
If aTon(i, 1) = MaSP Then
If dic.exists(aTon(i, 9)) = False Then
Call AddPhanXuong(fDay, aTon(i, 9), aTon(i, 2), aTon(i, 7))
End If
End If
Next i
rN = 1: rX = 1
If aNhap(rN, 1) <= aXuat(rX, 1) Then
Call AddNhap(MaSP, aXuat(rX, 1))
Else
Call AddXuat(MaSP, aNhap(rN, 1))
End If
sR = F + 1
For i = 1 To F
sR = sR + a(i)(0, 1)
Next i
ReDim res(1 To sR, 1 To 6)
k = 0
For i = 1 To F
For r = 1 To a(i)(0, 1)
k = k + 1
For j = 1 To 6
res(k, j) = a(i)(r, j)
Next j
Next r
tong = tong + res(k, 6)
k = k + 1
Next i
res(sR, 6) = tong
With Sheets("ChiTiet")
.Range("D3").ClearContents
i = .Range("G999999").End(xlUp).Row
If i > 5 Then .Range("B6:G" & i).Clear
If sR > 1 Then
.Range("B6").Resize(sR, 6) = res
.Range("B6").Resize(sR, 6).Borders.LineStyle = 1
.Range("D3").Value = a(1)(0, 2)
End If
End With
End Sub
Sub AddPhanXuong(fDay, ByVal PX, ByVal TenHang$, ByVal TonDau#)
F = F + 1 'So phan xuong
dic(PX) = F
ReDim Preserve a(1 To F)
a(F) = b
a(F)(0, 2) = TenHang 'Ten Hang
If TonDau > 0 Then
a(F)(0, 1) = 1 'Dong cuoi
a(F)(1, 1) = fDay
a(F)(1, 2) = PX
a(F)(1, 3) = TonDau
a(F)(1, 6) = TonDau
End If
End Sub
Sub AddNhap(MaSP, ByVal NgayXuat As Date)
For r = rN To srNhap
If aNhap(r, 1) <= NgayXuat Then
If aNhap(r, 4) = MaSP Then
If dic.exists(aNhap(r, 14)) = False Then
Call AddPhanXuong(fDay, aNhap(r, 14), aNhap(r, 5), 0)
End If
k = dic(aNhap(r, 14))
t = a(k)(0, 1) + 1 'Dong cuoi
a(k)(0, 1) = t
a(k)(t, 1) = aNhap(r, 1) 'Ngay
a(k)(t, 2) = aNhap(r, 14) 'Phan Xuong
a(k)(t, 4) = aNhap(r, 10) 'Nhap
If t > 1 Then
a(k)(t, 6) = a(k)(t - 1, 6) + aNhap(r, 10) 'Ton Cuoi
Else
a(k)(t, 6) = aNhap(r, 10) 'Ton Cuoi
End If
End If
Else
Exit For
End If
Next r
rN = r
If rN <= srNhap Then ngay = aNhap(rN, 1) Else ngay = DateValue("2050/1/1")
If rX <= srXuat Then Call AddXuat(MaSP, ngay)
End Sub
Sub AddXuat(MaSP, ByVal NgayNhap As Date)
For r = rX To srXuat
If aXuat(r, 1) < NgayNhap Then
If aXuat(r, 5) = MaSP Then
If dic.exists(aXuat(r, 15)) = False Then
Call AddPhanXuong(fDay, aXuat(r, 15), aXuat(r, 6), 0)
End If
k = dic(aXuat(r, 15))
t = a(k)(0, 1) + 1 'Dong cuoi
a(k)(0, 1) = t
a(k)(t, 1) = aXuat(r, 1) 'Ngay
a(k)(t, 2) = aXuat(r, 15) 'Phan Xuong
a(k)(t, 5) = aXuat(r, 9) 'Xuat
If t > 1 Then
a(k)(t, 6) = a(k)(t - 1, 6) - aXuat(r, 9) 'Ton Cuoi
Else
a(k)(t, 6) = -aXuat(r, 9) 'Ton Cuoi
End If
End If
Else
Exit For
End If
Next r
rX = r
If rX <= srXuat Then ngay = aXuat(rX, 1) Else ngay = DateValue("2050/1/1")
If rN <= srNhap Then Call AddNhap(MaSP, ngay)
End Sub
Option Explicit
Sub TonChiTiet()
Dim i&, j&, Lr&, t&, k&, X&, z&, Col&, tong&, TongT&, TongN&, TongX&
Dim ArrT(), ArrN(), ArrX(), KQ(), S, M
Dim ShT As Worksheet, ShN As Worksheet, ShX As Worksheet, Ws As Worksheet
Dim dic As Object, Key
Dim Ma As String
On Error GoTo Thoat
Application.ScreenUpdating = False
'Application.EnableEvents = False
Set dic = CreateObject("Scripting.Dictionary")
Set Ws = Sheets("ChiTiet")
Ma = Ws.[D2]
Set ShT = Sheets("TonDau")
Lr = ShT.Cells(1000000, 4).End(3).Row
ArrT = ShT.Range("D3:L" & Lr).Value
For i = 1 To UBound(ArrT)
If ArrT(i, 1) = Ma Then Key = ArrT(i, 1) & "|" & ArrT(i, 9): If Not dic.exists(Key) Then dic(Key) = i
Next i
Set ShN = Sheets("Nhap")
Lr = ShN.Cells(1000000, 4).End(3).Row
ArrN = ShN.Range("A3:N" & Lr).Value
For i = 1 To UBound(ArrN)
If ArrN(i, 4) = Ma Then
Key = ArrN(i, 4) & "|" & ArrN(i, 14)
If Not dic.exists(Key) Then
If InStr(1, dic(Key), "#N") = 0 Then dic(Key) = dic(Key) & "#N," & i Else dic(Key) = dic(Key) & "," & i
Else
If InStr(1, dic(Key), "#N") = 0 Then dic(Key) = dic(Key) & "#N," & i Else dic(Key) = dic(Key) & "," & i
End If
End If
Next i
Set ShX = Sheets("Xuat")
Lr = ShX.Cells(1000000, 7).End(3).Row
ArrX = ShX.Range("C3:Q" & Lr).Value
For i = 1 To UBound(ArrX)
If ArrX(i, 5) = Ma Then
Key = ArrX(i, 5) & "|" & ArrX(i, 15)
If Not dic.exists(Key) Then
If InStr(1, dic(Key), "#X") = 0 Then dic(Key) = dic(Key) & "#X," & i Else dic(Key) = dic(Key) & "," & i
Else
If InStr(1, dic(Key), "#X") = 0 Then dic(Key) = dic(Key) & "#X," & i Else dic(Key) = dic(Key) & "," & i
End If
End If
Next i
ReDim KQ(1 To dic.Count * 31, 1 To 7)
k = 1
For Each Key In dic.Keys
X = Split(Key, "|")(1): Col = 2
t = t + 1
If X <> k Then t = t + 1: k = X
S = Split(dic(Key), "#")
For i = LBound(S) To UBound(S)
Col = Col + 1
M = Split(S(i), ",")
If i >= 1 Then z = 1 Else z = 0
For j = z To UBound(M)
If i = 0 Then KQ(t, 1) = Sheets("TonDau").[E1]: KQ(t, 2) = X: KQ(t, Col) = ArrT(M(j), 7): KQ(t, 6) = KQ(t, Col) + KQ(t, Col + 1) - KQ(t, Col + 2): TongT = TongT + KQ(t, Col)
If i = 1 Then t = t + 1: KQ(t, 1) = ArrN(M(j), 1): KQ(t, 2) = X: KQ(t, Col) = ArrN(M(j), 10): KQ(t, 6) = KQ(t - 1, 6) + KQ(t, Col) - KQ(t, Col + 1): TongN = TongN + KQ(t, Col)
If i = 2 Then t = t + 1: KQ(t, 1) = ArrX(M(j), 1): KQ(t, 2) = X: KQ(t, Col) = ArrX(M(j), 9): KQ(t, 6) = KQ(t - 1, 6) + KQ(t, Col - 1) - KQ(t, Col): TongX = TongX + KQ(t, Col)
Next j
Next i
tong = tong + KQ(t, 6)
Next Key
If t Then
Ws.Range("B6").Resize(100000, 6).ClearContents
' Ws.Range("B6").Resize(100000, 6).Interior.Color = xlNone
' Ws.Range("B6").Resize(100000, 6).Borders.LineStyle = xlNone
Ws.Range("B6").Resize(t, 6) = KQ
Ws.Range("C" & t + 7) = Ws.[O1]
Ws.Range("D" & t + 7) = TongT
Ws.Range("E" & t + 7) = TongN
Ws.Range("F" & t + 7) = TongX
Ws.Range("G" & t + 7) = tong
' Ws.Range("B" & t + 7, "G" & t + 7).Interior.Color = vbYellow
Ws.Range("B6", "G" & t + 7).Borders.LineStyle = 1
End If
' Application.EnableEvents = True
Application.ScreenUpdating = True
Set dic = Nothing
MsgBox "Done"
Thoat:
If Err Then
MsgBox "Da có loi"
' Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
