Xin chào Admin, có thể..... dzu zi kỷ luật ban maiban2068 dài thêm tý không? Hôm nay mình mới Test , ok rồi bạn maiban2068 ơi, nhưng có chỗ này bạn có thể thêm dùm như sau được không? Dưới mỗi hàng sau khi tính toán ra , cho mình cột Sum như ban đầu. ( hình gửi đình kèm), mình chèn đuơng Link hình k biết đúng không? Xem dùm mình với.
Bạn @hocmoi thân mến. Cảm ơn bạn đã phản hồi lại cho chúng tôi.
Sub main()
Dim i As Long, rend As Long, j As Long
Dim cend As Integer
Dim arr 'Vung data tu cot V toi cot cuoi,tu dong rtitle toi rend
Dim crr 'Luu cong thuc
Dim Rng As Range
Dim flag1 As Boolean 'Phat hien san pham
Dim slcl As Double 'So luong con lai, cot V
Dim d As Double 'Du lieu dong rtitle
Dim checkrr
Const cV As Integer = 22 'Cot V
Const cW As Integer = 23 'Cot W chua cong thuc -vbano1 website tuhocvba.net
Const rtitle As Long = 3 'Dong chua thong tin ke hoach san xuat
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Xac dinh dong cuoi tren cot V
rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, cV).End(xlUp).Row
If rend <= rtitle + 1 Then
MsgBox "Khong co du lieu"
GoTo thoat
End If
'Xac dinh cot cuoi tren dong rtitle
cend = ThisWorkbook.ActiveSheet.Cells(rtitle, Columns.Count).End(xlToLeft).Column
If cend <= cV + 1 Then
MsgBox "Khong co du lieu"
GoTo thoat
End If
arr = ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cV), Cells(rend, cend)).Value
Set Rng = ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cW), Cells(rend, cW))
ReDim crr(1 To rend - rtitle + 1)
Call luucongthuc(Rng, crr)
flag1 = False
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
'V3 = "" and W3 <> ""
If (Trim(CStr(arr(i, 1))) = "") And (Trim(CStr(arr(i, 2))) <> "") Then
'Phat hien san pham
flag1 = True
slcl = 0
checkrr = ThisWorkbook.ActiveSheet.Range(Cells(rtitle + i - 1, cV), Cells(rtitle + i - 1, cend)).Value
Else
flag1 = False
End If
If flag1 = False Then
slcl = kiemtraso(Trim(CStr(arr(i, 1)))) + slcl 'Cot V
For j = 3 To UBound(arr, 2) Step 1 'Chay tu cot X toi cot cuoi
If slcl <= 0 Then Exit For 'Khong con kha nang cung ung
d = 0 'Du lieu dong rtile
If Trim(CStr(checkrr(1, j))) <> "" Then
If IsNumeric(Trim(CStr(checkrr(1, j)))) Then d = kiemtraso(Trim(CStr(checkrr(1, j))))
If d > 0 Then
If d <= slcl Then
arr(i, j) = d
slcl = slcl - d
checkrr(1, j) = 0
Else
arr(i, j) = slcl
checkrr(1, j) = d - slcl
slcl = 0
End If
End If
End If
Next j
End If
Next i
ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cV), Cells(rend, cend)).Value = arr
Call tralaicongthuc(Rng, crr)
thoat:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Not Number: -1111111
'Number: 0,1,2,...
Function kiemtraso(ByVal s As String) As Double
If s = "" Then
kiemtraso = -1111111
Exit Function
End If
If IsNumeric(s) = False Then
kiemtraso = -1111111
Else
kiemtraso = CDbl(s)
End If
End Function
Sub luucongthuc(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
Sub tralaicongthuc(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 SubXin chào bạn,
Bạn xem list video này nhé (Có nhiều video):
https://www.youtube.com/watch?v=rUwg2-gDRRc&list=PLCeKJ_XakmdmO0TXErVG3oyQT66lXPOnAConst rtitle As Long = 3 'Dong chua thong tin ke hoach san xuatOption Explicit
Sub abc()
Dim NumRow&, i&, j&, PrevCol&, LastRow&, NumCol&
Dim FirstRowOfProduct& 'Dong dau tien cua moi san pham
Dim tmp 'So luong san pham con lai trong ngay
Dim arrKQ(), arrSL()
LastRow = Sheets("file ban dau").Range("V1000000").End(xlUp).Row
arrSL = Sheets("file ban dau").Range("V3:W" & LastRow).Value
NumRow = LastRow - 2
NumCol = Sheets("file ban dau").Range("X2").End(xlToRight).Column() - Sheets("file ban dau").Range("W2").Column()
arrKQ = Sheets("file ban dau").Range("X3").Resize(NumRow, NumCol).Value
PrevCol = 1
FirstRowOfProduct = 1
PrevCol = 1
For i = 1 To NumRow
If Not IsNumeric(arrSL(i, 1) & arrSL(i, 2)) Then 'San pham moi
FirstRowOfProduct = i
tmp = arrKQ(i, 1)
PrevCol = 1
Else
For j = 1 To NumCol
If j < PrevCol Then
arrKQ(i, j) = Empty 'xoa bang de phong truong hop co du lieu sai
Else
PrevCol = j
If tmp > arrSL(i, 1) Then
arrKQ(i, j) = arrSL(i, 1)
tmp = tmp - arrSL(i, 1)
Exit For
Else
arrKQ(i, j) = tmp
arrSL(i, 1) = arrSL(i, 1) - tmp
If j < NumCol Then tmp = arrKQ(FirstRowOfProduct, j + 1)
End If
End If
Next
End If
Next
Sheets("file ban dau").Range("X3").Resize(NumRow, NumCol) = arrKQ
End SubEm nghĩ anh mường tượng vấn đề đúng.
Sub main()
Dim i As Long, rend As Long, j As Long
Dim cend As Integer, cendtem As Integer
Dim arr 'Vung data tu cot V toi cot cuoi,tu dong rtitle toi rend
Dim crr 'Luu cong thuc
Dim Rng As Range
Dim flag1 As Boolean 'Phat hien san pham
Dim slcl As Double 'So luong con lai, cot V
Dim d As Double 'Du lieu dong rtitle
Dim checkrr
Const cV As Integer = 22 'Cot V
Const cW As Integer = 23 'Cot W chua cong thuc -vbano1 website tuhocvba.net
Const rtitle As Long = 3 'Dong chua thong tin ke hoach san xuat
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Xac dinh dong cuoi tren cot V
rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, cV).End(xlUp).Row
If rend <= rtitle + 1 Then
MsgBox "Khong co du lieu"
GoTo thoat
End If
'Xac dinh cot cuoi tren dong rtitle
cendtem = 0
For i = rtitle To rend Step 1
cend = ThisWorkbook.ActiveSheet.Cells(i, Columns.Count).End(xlToLeft).Column
If cend > cendtem Then
cendtem = cend
End If
Next i
cend = cendtem
If cend <= cV + 1 Then
MsgBox "Khong co du lieu"
GoTo thoat
End If
arr = ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cV), Cells(rend, cend)).Value
Set Rng = ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cW), Cells(rend, cW))
ReDim crr(1 To rend - rtitle + 1)
Call luucongthuc(Rng, crr)
flag1 = False
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
'V3 = "" and W3 <> ""
If (Trim(CStr(arr(i, 1))) = "") And (Trim(CStr(arr(i, 2))) <> "") Then
'Phat hien san pham
flag1 = True
slcl = 0
checkrr = ThisWorkbook.ActiveSheet.Range(Cells(rtitle + i - 1, cV), Cells(rtitle + i - 1, cend)).Value
Else
flag1 = False
End If
If flag1 = False Then
slcl = kiemtraso(Trim(CStr(arr(i, 1)))) + slcl 'Cot V
For j = 3 To UBound(arr, 2) Step 1 'Chay tu cot X toi cot cuoi
If slcl <= 0 Then Exit For 'Khong con kha nang cung ung
d = 0 'Du lieu dong rtile
If Trim(CStr(checkrr(1, j))) <> "" Then
If IsNumeric(Trim(CStr(checkrr(1, j)))) Then d = kiemtraso(Trim(CStr(checkrr(1, j))))
If d > 0 Then
If d <= slcl Then
arr(i, j) = d
slcl = slcl - d
checkrr(1, j) = 0
Else
arr(i, j) = slcl
checkrr(1, j) = d - slcl
slcl = 0
End If
End If
End If
Next j
End If
Next i
ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cV), Cells(rend, cend)).Value = arr
Call tralaicongthuc(Rng, crr)
thoat:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Not Number: -1111111
'Number: 0,1,2,...
Function kiemtraso(ByVal s As String) As Double
If s = "" Then
kiemtraso = -1111111
Exit Function
End If
If IsNumeric(s) = False Then
kiemtraso = -1111111
Else
kiemtraso = CDbl(s)
End If
End Function
Sub luucongthuc(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
Sub tralaicongthuc(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 SubSub main()
Dim i As Long, rend As Long, j As Long
Dim cend As Integer
Dim arr 'Vung data tu cot V toi cot cuoi,tu dong rtitle toi rend
Dim crr 'Luu cong thuc
Dim Rng As Range
Dim flag1 As Boolean 'Phat hien san pham
Dim slcl As Double 'So luong con lai, cot V
Dim d As Double 'Du lieu dong rtitle
Dim checkrr
Const cV As Integer = 22 'Cot V
Const cW As Integer = 23 'Cot W chua cong thuc -vbano1 website tuhocvba.net
Const rtitle As Long = 3 'Dong chua thong tin ke hoach san xuat
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Xac dinh dong cuoi tren cot V
rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, cV).End(xlUp).Row
If rend <= rtitle + 1 Then
MsgBox "Khong co du lieu"
GoTo thoat
End If
'Xac dinh cot cuoi tren dong rtitle
cend = ThisWorkbook.ActiveSheet.Cells(rtitle-1, Columns.Count).End(xlToLeft).Column
If cend <= cV + 1 Then
MsgBox "Khong co du lieu"
GoTo thoat
End If
arr = ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cV), Cells(rend, cend)).Value
Set Rng = ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cW), Cells(rend, cW))
ReDim crr(1 To rend - rtitle + 1)
Call luucongthuc(Rng, crr)
flag1 = False
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
'V3 = "" and W3 <> ""
If (Trim(CStr(arr(i, 1))) = "") And (Trim(CStr(arr(i, 2))) <> "") Then
'Phat hien san pham
flag1 = True
slcl = 0
checkrr = ThisWorkbook.ActiveSheet.Range(Cells(rtitle + i - 1, cV), Cells(rtitle + i - 1, cend)).Value
Else
flag1 = False
End If
If flag1 = False Then
slcl = kiemtraso(Trim(CStr(arr(i, 1)))) + slcl 'Cot V
For j = 3 To UBound(arr, 2) Step 1 'Chay tu cot X toi cot cuoi
If slcl <= 0 Then Exit For 'Khong con kha nang cung ung
d = 0 'Du lieu dong rtile
If Trim(CStr(checkrr(1, j))) <> "" Then
If IsNumeric(Trim(CStr(checkrr(1, j)))) Then d = kiemtraso(Trim(CStr(checkrr(1, j))))
If d > 0 Then
If d <= slcl Then
arr(i, j) = d
slcl = slcl - d
checkrr(1, j) = 0
Else
arr(i, j) = slcl
checkrr(1, j) = d - slcl
slcl = 0
End If
End If
End If
Next j
End If
Next i
ThisWorkbook.ActiveSheet.Range(Cells(rtitle, cV), Cells(rend, cend)).Value = arr
Call tralaicongthuc(Rng, crr)
thoat:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Not Number: -1111111
'Number: 0,1,2,...
Function kiemtraso(ByVal s As String) As Double
If s = "" Then
kiemtraso = -1111111
Exit Function
End If
If IsNumeric(s) = False Then
kiemtraso = -1111111
Else
kiemtraso = CDbl(s)
End If
End Function
Sub luucongthuc(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
Sub tralaicongthuc(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
Chào các bạn, các bạn nhận ra vấn đề hay quá, mình mới copy code bạn BKKGG thì thấy phù hợp , để mình xem lại lần nũa xem còn chỗ nào còn bất thường không?
Hi bạn, Code của bạn ngắn gọn quá, bạn có thể diễn dãi tý mình hiểu thêm không? từ dòng code 10~35 đó.