Sub GiaXuat()
Dim aDM(), aNhap(), aXuat(), Res(), Dic As Object, ikey$
Dim eRow&, srDM&, srN&, srX&, frN&, frX&, i&, iR&, t&
'Khai bao lai cac tham so sau
Const dHang& = 500 'Tang so 500 neu Code loi do Ma hang qua nhieu
Const d& = 3 'So so le thap phan cua Gia xuat
Const fDay As Date = #1/31/2021# 'Ngay cuoi thang 1 nam 2021
'***********
Set Dic = CreateObject("scripting.dictionary")
With Sheets("DM_NVL")
aDM = .Range("A3:C" & .Range("C" & Rows.Count).End(xlUp).Row + dHang).Value
srDM = UBound(aDM) - dHang
End With
ReDim Preserve aDM(1 To srDM + dHang, 1 To 6)
For i = 1 To srDM
If aDM(i, 1) <> Empty Then Dic.Item(aDM(i, 1)) = i
Next i
With Sheets("BK_Nhap_156")
eRow = EndRow(.Name, "C")
.Range("A3:U" & eRow).Sort .[C3], 1, .[B3], , 1, Header:=xlNo
aNhap = .Range("C3:L" & eRow).Value
End With
With Sheets("BK_Xuat_156")
eRow = EndRow(.Name, "C")
.Range("A3:X" & eRow).Sort .[C3], 1, .[B3], , 1, Header:=xlNo
aXuat = .Range("C3:J" & eRow).Value
End With
srN = UBound(aNhap): srX = UBound(aXuat)
ReDim Res(1 To srX, 1 To 2)
frN = 1: frX = 1
For n = 1 To 12
For i = frN To srN
If TypeName(aNhap(i, 1)) = "Date" Then
If aNhap(i, 1) <= fDay Then t = 1 Else t = Month(aNhap(i, 1))
If t > n Then frN = i: Exit For
ikey = aNhap(i, 5)
If Dic.exists(ikey) = False Then
srDM = srDM + 1
Dic.Add ikey, srDM
aDM(srDM, 1) = ikey: aDM(srDM, 2) = aNhap(i, 6): aDM(srDM, 3) = aNhap(i, 7)
End If
iR = Dic.Item(ikey)
aDM(iR, 4) = aDM(iR, 4) + aNhap(i, 8)
aDM(iR, 5) = aDM(iR, 5) + aNhap(i, 10)
End If
Next i
For i = 1 To srDM
If aDM(i, 4) > 0 Then aDM(i, 6) = Round(aDM(i, 5) / aDM(i, 4), d)
Next i
For i = frX To srX
If TypeName(aXuat(i, 1)) = "Date" Then
t = Month(aXuat(i, 1))
If t > n Then frX = i: Exit For
ikey = aXuat(i, 5)
If Dic.exists(ikey) = False Then
srDM = srDM + 1
Dic.Add ikey, srDM
aDM(srDM, 1) = ikey: aDM(srDM, 2) = aXuat(i, 6): aDM(srDM, 3) = aXuat(i, 7)
End If
iR = Dic.Item(ikey)
Res(i, 1) = aDM(iR, 6)
Res(i, 2) = Round(Res(i, 1) * aXuat(i, 8), 0)
aDM(iR, 4) = aDM(iR, 4) - aXuat(i, 8)
aDM(iR, 5) = aDM(iR, 5) - Res(i, 2)
If aDM(iR, 4) < 0 Then MsgBox (" Ma Hang Ton Kho Am:" & Chr(10) & "Tháng " & t & ": " & ikey)
End If
Next i
Next n
Sheets("BK_Xuat_156").Range("K3").Resize(srX, 2) = Res
'Sheets("DM_NVL").Range("A3").Resize(srDM, 3) = aDM 'Them Ma Hang
End Sub
Sub NXT()
Dim aDM(), aNhap(), aXuat(), Res(), Dic As Object, ikey$
Dim eRow&, srDM&, srN&, srX&, frN&, frX&, i&, iR&, j&
Dim fDay As Date, eDay As Date, tmp, tTT
'Khai bao lai cac tham so sau
Const dHang& = 500 'Tang so 500 neu Code loi do Ma hang qua nhieu
Const d& = 3 'So so le thap phan cua Gia xuat
'***********
Set Dic = CreateObject("scripting.dictionary")
With Sheets("DM_NVL")
aDM = .Range("A3:C" & .Range("C" & Rows.Count).End(xlUp).Row + dHang).Value
srDM = UBound(aDM) - dHang
End With
ReDim Res(1 To srDM + dHang, 1 To 13)
For i = 1 To srDM
If aDM(i, 1) <> Empty Then Dic.Item(aDM(i, 1)) = i
Next i
On Error Resume Next
With Sheets("BCNXT")
eRow = .Range("A" & Rows.Count).End(xlUp).Row
If eRow > 9 Then .Range("A10:M" & eRow).ClearContents
fDay = .Range("N1").Value: eDay = .Range("N2").Value
If fDay = Empty Or eDay = Empty Or Err > 0 Then MsgBox ("Thoi Gian Bao Cao Sai"): Exit Sub
End With
On Error GoTo 0
With Sheets("BK_Nhap_156")
eRow = EndRow(.Name, "C")
aNhap = .Range("C3:L" & eRow).Value
End With
With Sheets("BK_Xuat_156")
eRow = EndRow(.Name, "C")
aXuat = .Range("C3:L" & eRow).Value
End With
srN = UBound(aNhap): srX = UBound(aXuat)
For i = 1 To srN
tmp = aNhap(i, 1)
If TypeName(tmp) = "Date" Then
ikey = aNhap(i, 5)
If Dic.exists(ikey) = False Then
srDM = srDM + 1
Dic.Add ikey, srDM
aDM(srDM, 1) = ikey: aDM(srDM, 2) = aNhap(i, 6): aDM(srDM, 3) = aNhap(i, 7)
End If
iR = Dic.Item(ikey)
If tmp < fDay Then
Res(iR, 5) = Res(iR, 5) + aNhap(i, 8)
Res(iR, 6) = Res(iR, 6) + aNhap(i, 10)
ElseIf tmp <= eDay Then
Res(iR, 7) = Res(iR, 7) + aNhap(i, 8)
Res(iR, 8) = Res(iR, 8) + aNhap(i, 10)
Else
Exit For
End If
End If
Next i
For i = 1 To srX
tmp = aXuat(i, 1)
If TypeName(tmp) = "Date" Then
ikey = aXuat(i, 5)
If Dic.exists(ikey) = False Then
srDM = srDM + 1
Dic.Add ikey, srDM
aDM(srDM, 1) = ikey: aDM(srDM, 2) = aXuat(i, 6): aDM(srDM, 3) = aXuat(i, 7)
End If
iR = Dic.Item(ikey)
If tmp < fDay Then
Res(iR, 5) = Res(iR, 5) - aXuat(i, 8)
Res(iR, 6) = Res(iR, 6) - aXuat(i, 10)
ElseIf tmp <= eDay Then
Res(iR, 9) = Res(iR, 9) + aXuat(i, 8)
Res(iR, 10) = Res(iR, 10) + aXuat(i, 10)
Else
Exit For
End If
End If
Next i
For i = 1 To srDM
For j = 5 To 11 Step 2
If Res(i, j) > 0 Then Exit For
Next j
If j <= 11 Then
k = k + 1
For j = 1 To 3
Res(k, j) = aDM(i, j)
Next j
For j = 5 To 10
Res(k, j) = Res(i, j)
Next j
tmp = Res(k, 5) + Res(k, 7)
If tmp > 0 Then Res(k, 4) = Round((Res(k, 6) + Res(k, 8)) / tmp, d)
Res(k, 11) = Res(k, 5) + Res(k, 7) - Res(k, 9)
Res(k, 12) = Res(k, 6) + Res(k, 8) - Res(k, 10)
End If
Next i
Sheets("BCNXT").Range("A10").Resize(k, 12) = Res
'Sheets("DM_NVL").Range("A3").Resize(srDM, 3) = aDM 'Them Ma Hang
End Sub
Private Function EndRow(ByVal shName$, ByVal jCol$)
Dim eRow&, i&
With Sheets(shName)
eRow = .Range("L" & Rows.Count).End(xlUp).Row
For i = eRow To 3 Step -1
If TypeName(.Range(jCol & i).Value) = "Date" Then EndRow = i: Exit Function
Next i
End With
End Function
