Option Explicit
Enum ColRes
idNo = 1
idTenHang = 2 [B][COLOR=#ff0000]<-----em chỉnh chổ này[/COLOR][/B]
idMaHang = 3
idDVT = 4
idTonDK = 5
idNhap = 6
idXuat = 7
idTonCK = 8
End Enum
Sub BaoCaoNhapXuatTon()
Application.ScreenUpdating = False
''Nap cac Du lieu nhap
Dim DmvTon(), MhNhap(), ddNhap(), SlgNhap(), MhXuat(), SlgXuat(), ddXuat()
Dim nDM As Long, nNhap As Long, nXuat As Long, nRes As Long
Dim Dic, arNXT(), aAdd()
Dim I As Long, K As Long, ddFr As Long, ddTo As Long, ik As ColRes
'Nhap cac du lieu Danh muc Hang Hoa va TonDau
With Range("DmvTon")
If .Offset(1).Value <> "" Then
DmvTon = Range(.Offset(1), .Offset(1).End(xlDown)).Resize(, 3).Value2
nDM = UBound(DmvTon)
Else
MsgBox "Xem lai Du lieu Danh muc va Ton", vbOKOnly + vbCritical, "Danh muc va Ton"
Exit Sub
End If
End With
'Nhap Du lieu NHAP
With Range("NHAP")
If .Offset(1).Value <> "" Then
MhNhap = Range(.Offset(1), .End(xlDown)).Value2
nNhap = UBound(MhNhap)
SlgNhap = .Offset(1, 2).Resize(nNhap).Value2
ddNhap = .Offset(1, -3).Resize(nNhap).Value2
Else
MsgBox "Xem lai Du lieu chung tu NHAP", vbOKOnly + vbCritical, "Chung tu Nhap"
Exit Sub
End If
End With
'Nhap Du lieu XUAT
With Range("XUAT")
If .Offset(1).Value <> "" Then
MhXuat = Range(.Offset(1), .End(xlDown)).Value2
nXuat = UBound(MhXuat)
SlgXuat = .Offset(1, 2).Resize(nXuat).Value2
ddXuat = .Offset(1, -5).Resize(nXuat).Value2
Else
MsgBox "Xem lai Du lieu chung tu XUAT", vbOKOnly + vbCritical, "Chung tu Xuat"
Exit Sub
End If
End With
'Nhap Du lieu Tu Ngay -> Den Ngay
ddFr = Range("TUNGAY").Value2
ddTo = Range("DENNGAY").Value2
Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To nDM
Dic(DmvTon(I, 1)) = I
Next I
ReDim arNXT(1 To nDM + 10, idTonDK To idXuat)
For I = 1 To nDM
arNXT(I, idTonDK) = DmvTon(I, 2)
Next I
ReDim Preserve aAdd(1 To 1)
nRes = nDM
For I = 1 To nNhap
If ddNhap(I, 1) <= ddTo Then
K = Dic(MhNhap(I, 1))
If K = 0 Then
nRes = nRes + 1: K = nRes: Dic(MhNhap(I, 1)) = K
ReDim Preserve aAdd(1 To nRes - nDM): aAdd(nRes - nDM) = MhNhap(I, 1)
End If
If ddNhap(I, 1) < ddFr Then 'ton
arNXT(K, idTonDK) = arNXT(K, idTonDK) + SlgNhap(I, 1)
Else 'trong ky
arNXT(K, idNhap) = arNXT(K, idNhap) + SlgNhap(I, 2)
End If
End If
Next I
For I = 1 To nXuat
If ddXuat(I, 1) <= ddTo Then
K = Dic(MhXuat(I, 1))
If K = 0 Then
nRes = nRes + 1: K = nRes: Dic(MhXuat(I, 1)) = K
ReDim Preserve aAdd(1 To nRes - nDM): aAdd(nRes - nDM) = MhXuat(I, 1)
End If
If ddXuat(I, 1) < ddFr Then 'ton
arNXT(K, idTonDK) = arNXT(K, idTonDK) - SlgXuat(I, 1)
Else 'trong ky
arNXT(K, idXuat) = arNXT(K, idXuat) + SlgXuat(I, 1)
End If
End If
Next I
Range("KETQUA").Offset(1).Resize(6000, idTonCK).ClearContents
With Range("KETQUA").Offset(1)
K = -1
For I = 1 To nRes
If arNXT(I, idTonDK) <> 0 Or arNXT(I, idNhap) <> 0 Or arNXT(I, idXuat) <> 0 Then 'khong lay ton, nhap, xuat bang 0
K = K + 1
.Offset(K, idNo - 1).Value = K + 1
If I <= nDM Then
.Offset(K, idMaHang - 1) = DmvTon(I, 1)
.Offset(K, idTenHang - 1) = DmvTon(I, -1) [B][COLOR=#ff0000]<--------em chỉnh chổ này[/COLOR][/B]
.Offset(K, idDVT - 1) = DmvTon(I, 4)
Else
.Offset(K, idMaHang - 1) = aAdd(I - nDM)
End If
For ik = idTonDK To idXuat
.Offset(K, ik - 1) = arNXT(I, ik)
Next
.Offset(K, idTonCK - 1) = arNXT(I, idTonDK) + arNXT(I, idNhap) - arNXT(I, idXuat)
End If
Next I
End With
K = K + 1
Application.ScreenUpdating = True
If nRes > nDM Then
MsgBox "Chuong trinh ket thuc" _
& vbLf & "co tat ca " & K & " ma hang duoc tinh NXT" _
& vbLf & vbLf & "Co " & nRes - nDM & " mat hang cuoi chua co trong Danh muc", _
vbOKOnly + vbCritical, "THONG BAO"
Else
MsgBox "Chuong trinh ket thuc" _
& vbLf & "co tat ca " & K & " ma hang duoc tinh NXT", _
vbOKOnly, "THONG BAO"
End If
End Sub[COLOR=#000000]Enum ColRes[/COLOR] idNo = 1
idTenHang = 2 [B][COLOR=#ff0000]<-----em chỉnh chổ này[/COLOR][/B]
idMaHang = 3
idDVT = 4
idTonDK = 5
idNhap = 6
idXuat = 7
idTonCK = 8 [COLOR=#000000]End Enum[/COLOR][COLOR=#000000] If I <= nDM Then[/COLOR] .Offset(K, idMaHang - 1) = DmvTon(I, 1)
.Offset(K, idTenHang - 1) = DmvTon(I, -1) [B][COLOR=#ff0000]<--------em chỉnh chổ này[/COLOR][/B]
.Offset(K, idDVT - 1) = DmvTon(I, 4)
Else
.Offset(K, idMaHang - 1) = aAdd(I - nDM) [COLOR=#000000] End If[/COLOR]
Sub GPE()
Dim TNgay As Long, DNgay As Long, Endr As Long, Arr(), KQ(), i As Long, j As Long, k As Long, Dic As Object
Dim Ma As String
With Sheet4
TNgay = .Range("TUNGAY").Value 'tu ngay
DNgay = .Range("DENNGAY").Value 'den ngay
Set Dic = CreateObject("Scripting.Dictionary")
Endr = .Range("B65500").End(xlUp).Row
If Endr > 4 Then .Range("KETQUA").Offset(1).Resize(Endr - 4, 8).ClearContents
ReDim KQ(1 To 100, 1 To 8)
'lam dau ky
With Sheet1
Endr = .Range("G65500").End(xlUp).Row
If Endr > 3 Then
Arr = .Range("F4").Resize(Endr - 3, 4)
For i = 1 To Endr - 3
Ma = UCase(Trim(Arr(i, 2))) 'chuyen ve cho cung dinh dang
If Not Dic.Exists(Ma) Then
j = j + 1
Dic.Add Ma, j
KQ(j, 1) = j 'so thu tu
KQ(j, 2) = Arr(i, 1) 'ten hang hoa
KQ(j, 3) = Arr(i, 2) 'ma hang hoa
KQ(j, 4) = Arr(i, 3) 'don vi tinh
KQ(j, 5) = Arr(i, 4) 'ton dau nam
Else
k = Dic.Item(Ma)
KQ(k, 5) = KQ(k, 5) + Arr(i, 4) 'cong don so luong dau nam
End If
Next i
End If
End With
'lam nhap kho
With Sheet2
Endr = .Range("C65500").End(xlUp).Row
If Endr > 2 Then
Arr = .Range("C3").Resize(Endr - 2, 6)
For i = 1 To Endr - 2
If Arr(i, 1) <= DNgay Then 'neu ngay nhap < ngay ket thuc can lam bao cao
Ma = UCase(Trim(Arr(i, 4)))
If Not Dic.Exists(Ma) Then 'neu chua co ma hang nay => them vao dic
j = j + 1
Dic.Add Ma, j
KQ(j, 1) = j 'so thu tu
KQ(j, 2) = Arr(i, 3) 'ten hang hoa
KQ(j, 3) = Arr(i, 4) 'ma hang hoa
KQ(j, 4) = Arr(i, 5) 'don vi tinh
KQ(j, 6) = Arr(i, 6) 'nhap kho
Else 'neu co roi => cong don nhap kho
k = Dic.Item(Ma)
KQ(k, 6) = KQ(k, 6) + Arr(i, 6) 'cong don so luong nhap kho
End If
End If
Next i
End If
End With
'lam xuat kho
With Sheet3
Endr = .Range("B65500").End(xlUp).Row
If Endr > 2 Then
Arr = .Range("B3").Resize(Endr - 2, 8)
For i = 1 To Endr - 2
If Arr(i, 1) <= DNgay Then 'neu ngay nhap < ngay ket thuc can lam bao cao
Ma = UCase(Trim(Arr(i, 6)))
If Not Dic.Exists(Ma) Then 'neu chua co ma hang nay => them vao dic
j = j + 1
Dic.Add Ma, j
KQ(j, 1) = j 'so thu tu
KQ(j, 2) = Arr(i, 5) 'ten hang hoa
KQ(j, 3) = Arr(i, 6) 'ma hang hoa
KQ(j, 4) = Arr(i, 7) 'don vi tinh
KQ(j, 7) = Arr(i, 8) 'xuat kho
Else 'neu co roi => cong don xuat kho
k = Dic.Item(Ma)
KQ(k, 7) = KQ(k, 7) + Arr(i, 8) 'cong don so luong xaut kho
End If
End If
Next i
End If
End With
'lam lai bang NXT
For i = 1 To j
KQ(i, 8) = KQ(i, 5) + KQ(i, 6) - KQ(i, 7) ' ton cuoi = dau ky + nhap kho - xuat kho
Next i
.Range("KETQUA").Offset(1).Resize(j, 8).Value = KQ
Set Dic = Nothing
End With
End Sub
Bạn xem file rồi so sánh code mới với code mà bạn đang cố gắng điều chỉnh, rồi tự rút ra kinh nghiệm cho bản thân khi làm việc với co số.
Sub NXT()
Dim Data(), Sarr(), i, j, k, x, n, y, sh
Dim Kq(1 To 65536, 1 To 8), LastD
Sarr = Array("TON", "NHAP", "XUAT")
LastD = Range("DENNGAY").Value
With CreateObject("scripting.dictionary")
For x = 0 To 2
Set sh = Sheets(Sarr(x))
Data = sh.Range("A3", sh.[I65536].End(3)).Value
For i = 1 To UBound(Data)
If Data(i, 2) <= LastD Then
If Not .exists(Data(i, 7)) Then
k = k + 1
.Add Data(i, 7), k
Kq(k, 1) = k
For n = 2 To 4
Kq(k, n) = Data(i, 4 + n)
Next
Kq(k, x + 5) = Data(i, 9)
Kq(k, 8) = Kq(k, 5) + Kq(k, 6) - Kq(k, 7)
Else
y = .Item(Data(i, 7))
Kq(y, x + 5) = Kq(y, x + 5) + Data(i, 9)
Kq(y, 8) = Kq(y, 5) + Kq(y, 6) - Kq(y, 7)
End If
End If
Next
Next
End With
Sheets("NXT").[A5:H1000].ClearContents
Sheets("NXT").[A5].Resize(k, 8) = Kq
End Sub
