'Thong tin ung ho dien dan:
'So tai khoan: 0011003264055
'Ngan hang Vietcombank
'Chi nhanh ngan hang: Quan Hoan Kiem, Ha Noi
'Chu tai khoan: Pham Minh Hoang
Type sanpham
sldu As Double 'so luong dap ung
rowsp As Long 'dong chua ten san pham. Ex: row = 10
ipv As Double 'input vao
End Type
Sub tuhocvba175()
Dim i As Long, j As Long
Dim cend As Integer
Dim rend As Long, r As Long
Dim sp() As sanpham
Dim arr
Dim cnt As Long
Dim d As Double, d2 As Double 'd: input vao, d2: san luong dap ung
Dim Rng As Range
Dim crr
Const cotw As Integer = 23 'cot W
Const rstart As Long = 1 'Dong tieu de, dong 1
Const r2 As Long = 10 'Dong bat dau chua ten san pham, dong 10
cnt = 0
With ThisWorkbook.ActiveSheet
rend = .Cells(.Rows.Count, cotw - 1).End(xlUp).Row
cend = .Cells(rstart, .Columns.Count).End(xlToLeft).Column
If rend <= r2 Then GoTo thoat
If cend <= cotw Then GoTo thoat
arr = .Range(.Cells(r2, cotw - 1), .Cells(rend, cend)).Value
.Range(.Cells(r2, cotw), .Cells(rend, cend)).Interior.Color = xlNone 'Reset color
Set Rng = .Range(.Cells(r2, cotw), .Cells(rend, cotw))
End With
'Luu cong thuc
ReDim crr(1 To rend - r2 + 1)
Call luucongthuc2(Rng, crr)
d = 0
d2 = 0
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
'Nhan biet ten san pham
If Trim(CStr(arr(i, 2))) <> "" And Trim(CStr(arr(i, 1))) = "" Then 'Cot V la rong, cot W khac rong
cnt = cnt + 1
ReDim Preserve sp(1 To cnt)
sp(cnt).rowsp = i
If cnt > 1 Then
sp(cnt - 1).sldu = d2
End If
'tinh input dau vao
d = 0
d2 = 0
For j = 3 To UBound(arr, 2) Step 1
d = d + kiemtrasodouble(CStr(arr(i, j)))
Next j
sp(cnt).ipv = d
d = 0
Else
d2 = d2 + kiemtrasodouble(CStr(arr(i, 1)))
If i = UBound(arr, 1) Then
sp(cnt).sldu = d2
End If
End If
Next i
'Logic kiem tra 3 truong hop
If cnt = 0 Then GoTo thoat
With ThisWorkbook.ActiveSheet
For i = 1 To cnt Step 1
If sp(i).ipv = sp(i).sldu Then
'OK
ElseIf sp(i).ipv < sp(i).sldu Then
r = sp(i).rowsp
r = r2 + r - 1
.Range(.Cells(r, cotw), .Cells(r, cend)).Interior.ColorIndex = 3
Else
r = sp(i).rowsp
d = 0
For j = UBound(arr, 2) To 3 Step -1
If d > sp(i).sldu Then
arr(r, j) = ""
Else
If d + kiemtrasodouble(CStr(arr(r, j))) > sp(i).sldu Then
arr(r, j) = sp(i).sldu - d
If kiemtrasodouble(CStr(arr(r, j))) = 0 Then
arr(r, j) = ""
End If
d = sp(i).sldu + 1
Else
d = d + kiemtrasodouble(CStr(arr(r, j)))
End If
End If
Next j
End If
Next i
.Range(.Cells(r2, cotw - 1), .Cells(rend, cend)).Value = arr
End With
Call tralaicongthuc2(Rng, crr)
Exit Sub
thoat:
MsgBox "Khong tim thay du lieu"
End Sub
Function kiemtrasodouble(ByVal s As String) As Double
If s = "" Then
kiemtrasodouble = 0
Exit Function
End If
If IsNumeric(s) = False Then
kiemtrasodouble = 0
Else
kiemtrasodouble = CDbl(s)
End If
End Function
'https://tuhocvba.net/threads/quan-ly-luong-hang-san-xuat-bang-vba.654/page-2#post-3685
Sub tralaicongthuc2(ByVal Rng As Range, ByRef crr As Variant)
Dim rr As Range
Dim cnt As Long
cnt = 0
For Each rr In Rng
cnt = cnt + 1
If CStr(crr(cnt)) <> "" Then
rr.Formula = CStr(crr(cnt))
End If
Next
End Sub
Sub luucongthuc2(ByVal Rng As Range, ByRef crr As Variant)
Dim cnt As Long
Dim congthuc As String
Dim rr As Range
cnt = 0
For Each rr In Rng
cnt = cnt + 1
If rr.HasFormula = True Then
crr(cnt) = rr.Formula
Else
crr(cnt) = ""
End If
Next
End Sub
