Quản lý lượng hàng sản xuất bằng VBA

Trạng thái
Không mở trả lời sau này.

hocmoi

Yêu THVBA
Bạn @hocmoi nhanh chóng xác nhận kết quả macro như thế đã đúng ý bạn chưa.
Ngày 1/4, chúng tôi thi hành kỷ luật xóa nick @maiban2068 .
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.
Cám ơn.
 

tuhocvba

Administrator
Thành viên BQT
Chào bạn @hocmoi . Nick maiban2068 đã được xóa theo thông báo trước đó. Chúng tôi rất tiếc khi phải thông báo như vậy. Hiện nay không biết bạn ấy có tham gia nữa không, nếu tham gia thì là nick gì-chúng tôi không biết.
Topic này @Euler sẽ hỗ trợ. Cho tới chủ nhật tuần này sẽ xong. Cho tới lúc đó nếu có vấn đề gì không hiểu hoặc cần thông tin thêm, @Euler sẽ liên lạc với bạn.
 

Euler

Administrator
Thành viên BQT
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.
Cám ơn.
Bạn @hocmoi thân mến. Cảm ơn bạn đã phản hồi lại cho chúng tôi.
Mình hiểu yêu cầu rồi, mình sẽ hỗ trợ topic này.
Bạn cần đăng nhập để thấy hình ảnh

Hiện tại cũng đã muộn, có gì tối mai mình sẽ phản hồi lại cho bạn.
 

vbano1

SMod
Thành viên BQT
Cảm ơn bạn đã tham gia diễn đàn cùng chúng tôi.
Mình xin được hỗ trợ topic này giúp Euler:
1. Code:
Mã:
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 Sub
Kết quả:
Bạn cần đăng nhập để thấy hình ảnh

2. Giải thích:
Code của bạn maiban2068 đã đáp ứng yêu cầu của bạn. Do đó mình không thay đổi logic của code cũ.
Yêu cầu của bạn là trả lại công thức vốn có của cột W. Do đây là lỗi thiết kế, cột phụ được chèn vào giữa vùng dữ liệu cần tính toán, khi nạp dữ liệu vào mảng để xử lý, sau khi tính toán xong, code cũ trả kết quả này về vùng dữ liệu cũ. Do đó cột W nếu có công thức thì sẽ mất.
Bạn cần đăng nhập để thấy hình ảnh


Theo qui định của diễn đàn, bạn có 7 ngày để phản hồi lại cho chúng tôi biết là chúng tôi đã đáp ứng yêu cầu của bạn hay chưa.
Trong trường hợp chưa đáp ứng, mong muốn bạn chỉ rõ vị trí nào, kết quả hiện tại đang là gì, mong muốn sửa lại thành gì. Sử dụng hình ảnh để chúng tôi dễ hình dung và nhanh chóng hỗ trợ bạn.
Nếu sau 7 ngày không có phản hồi, yêu cầu này sẽ Close theo qui định hiện nay của diễn đàn.
Mong bạn nhanh chóng xác nhận và phản hồi lại cho chúng tôi sớm.
 

hocmoi

Yêu THVBA
Cảm ơn bạn đã tham gia diễn đàn cùng chúng tôi.
Mình xin được hỗ trợ topic này giúp Euler:
1. Code:
Mã:
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 Sub
Kết quả:
Bạn cần đăng nhập để thấy hình ảnh

2. Giải thích:
Code của bạn maiban2068 đã đáp ứng yêu cầu của bạn. Do đó mình không thay đổi logic của code cũ.
Yêu cầu của bạn là trả lại công thức vốn có của cột W. Do đây là lỗi thiết kế, cột phụ được chèn vào giữa vùng dữ liệu cần tính toán, khi nạp dữ liệu vào mảng để xử lý, sau khi tính toán xong, code cũ trả kết quả này về vùng dữ liệu cũ. Do đó cột W nếu có công thức thì sẽ mất.
Bạn cần đăng nhập để thấy hình ảnh


Theo qui định của diễn đàn, bạn có 7 ngày để phản hồi lại cho chúng tôi biết là chúng tôi đã đáp ứng yêu cầu của bạn hay chưa.
Trong trường hợp chưa đáp ứng, mong muốn bạn chỉ rõ vị trí nào, kết quả hiện tại đang là gì, mong muốn sửa lại thành gì. Sử dụng hình ảnh để chúng tôi dễ hình dung và nhanh chóng hỗ trợ bạn.
Nếu sau 7 ngày không có phản hồi, yêu cầu này sẽ Close theo qui định hiện nay của diễn đàn.
Mong bạn nhanh chóng xác nhận và phản hồi lại cho chúng tôi sớm.
Xin chào bạn,
Cám ơn bạn đã giải quyết vấn đề nhanh chóng. Ok mình đã Text.
P/S: thấy VBA hay quá, không biết mình muốn học để tập làm cho công việc của mình? Có "dễ" không bạn, mình đi làm suốt ngày , chỉ rảnh tý buổi tối, tính tạp làm quen với VBA, mà không biết học vơi ai, nhờ chỉ giúp với.
 

tuhocvba

Administrator
Thành viên BQT
Xin chào bạn,
Cám ơn bạn đã giải quyết vấn đề nhanh chóng. Ok mình đã Text.
P/S: thấy VBA hay quá, không biết mình muốn học để tập làm cho công việc của mình? Có "dễ" không bạn, mình đi làm suốt ngày , chỉ rảnh tý buổi tối, tính tạp làm quen với VBA, mà không biết học vơi ai, nhờ chỉ giúp với.
Bạn xem list video này nhé (Có nhiều video):
Mã:
https://www.youtube.com/watch?v=rUwg2-gDRRc&list=PLCeKJ_XakmdmO0TXErVG3oyQT66lXPOnA
 

Euler

Administrator
Thành viên BQT
@hocmoi : Phần lớn các bạn lên đây hỏi, đều chuyên ngành tài chính, kế toán. Vì vậy cái các bạn thiếu là thuật toán, chứ không phải kiến thức VBA.
Hiện nay các trung tâm, khóa học mở ra thì lại đi theo hướng dạy về VBA.
Nếu không có logic thuật toán, dù học 10 buổi, hay 20 buổi thì cũng vô nghĩa. Vậy, bước đầu tiên, bạn cứ mang các vấn đề của bạn lên diễn đàn, và cố gắng trình bày dễ hiểu, logic. Như thế cũng là đang học VBA rồi.
Bây giờ, ngay việc trình bày cho người khác hiểu còn chưa xong, đăng ký học khóa A hay khóa B thì cũng là lãng phí.
Diễn đàn không tổ chức khóa học, đây là diễn đàn Tự Học.

Bạn có thể mang các vấn đề của bạn lên đây để hỏi đáp, khi nhận follow trình bày dễ hiểu thì đừng tự ái. Biết cách diễn đạt thông tin, đó chính là khởi đầu để học VBA đấy ạ.
 

NhanSu

SMod
Thành viên BQT
@hocmoi @vbano1 theo mình dòng code số 13 trong bài 27 chưa chính xác
Mã:
Const rtitle    As Long = 3 'Dong chua thong tin ke hoach san xuat
Dòng số 3 này chỉ đúng với sản phẩm A, sản phẩm này kết thúc ở ngày 15 nên toàn bộ bảng dữ liệu chỉ lấy đến cột 15. Nếu sản phẩm B có kế hoạch sản xuất ở ngày 16 thì kết quả sẽ sai, bạn thử điền một số vào ô AM10 (cột ngày 16 của sản phẩm B) sẽ thấy không ra kết quả. Vì đó là code của người khác nên mình không xem thêm nữa.
Dưới đây là code của mình để bạn tham khảo
Mã:
Option 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 Sub
 
D

Deleted member 208

Guest
@hocmoi @vbano1 theo mình dòng code số 13 trong bài 27 chưa chính xác
Mã:
Const rtitle    As Long = 3 'Dong chua thong tin ke hoach san xuat
Dòng số 3 này chỉ đúng với sản phẩm A, sản phẩm này kết thúc ở ngày 15 nên toàn bộ bảng dữ liệu chỉ lấy đến cột 15. Nếu sản phẩm B có kế hoạch
Em nghĩ anh mường tượng vấn đề đúng.
Ở bài trước tác giả code cũng đã nói logic mà không thấy chủ topic phản hồi nên em nghĩ vấn đề này đã được bỏ qua.

Trong trường hợp các sản phẩm B, C, D có cột kết thúc ở xa hơn sản phẩm A, thì vẫn có cách khắc phục không cần sửa code.
Bạn cần đăng nhập để thấy hình ảnh


Giả sử chủ topic muốn kết thúc ở côt AM, thì ở các dòng sản phẩm A,B,C,D... tại cột AM điền vào là 0. Code vẫn chạy đúng.

Tuy nhiên có lẽ không ai muốn chạy code mà còn phải can thiệp bằng tay. Cho nên:
Vấn đề ở cột cuối có thể khắc phục là:
Mã:
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 Sub
 

BKKBG

Yêu THVBA nhất
Nhìn ra vấn đề cột cuối có thiếu sót thì đâu cần xử lý như #32, #33 làm gì cho tốn công tốn sức nhỉ.
Thay vì lấy cột cuối ở dòng 3, thì sửa lại là lấy cột cuối ở dòng 2. Vì dòng 2 theo như data chủ topic đưa lên là full dữ liệu.
Tôi sửa code dòng 23 là xong.
Bạn cần đăng nhập để thấy hình ảnh

Mã:
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-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
 

giaiphapvba

Administrator
Thành viên BQT
Xác nhận phản hồi của @NhanSu đưa ra là đúng. Cảm ơn bạn NhanSu.
Xác nhận code #33, code #34 fix code của tác giả maiban2068 là đúng.
Bạn @hocmoi có thể sử dụng code , hoặc code .
 

hocmoi

Yêu THVBA
Nhìn ra vấn đề cột cuối có thiếu sót thì đâu cần xử lý như #32, #33 làm gì cho tốn công tốn sức nhỉ.
Thay vì lấy cột cuối ở dòng 3, thì sửa lại là lấy cột cuối ở dòng 2. Vì dòng 2 theo như data chủ topic đưa lên là full dữ liệu.
Tôi sửa code dòng 23 là xong.
Bạn cần đăng nhập để thấy hình ảnh

Mã:
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-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?
Cám ơn tất cả các bạn nhiều.
 

hocmoi

Yêu THVBA
@hocmoi @vbano1 theo mình dòng code số 13 trong bài 27 chưa chính xác
Mã:
Const rtitle    As Long = 3 'Dong chua thong tin ke hoach san xuat
Dòng số 3 này chỉ đúng với sản phẩm A, sản phẩm này kết thúc ở ngày 15 nên toàn bộ bảng dữ liệu chỉ lấy đến cột 15. Nếu sản phẩm B có kế hoạch sản xuất ở ngày 16 thì kết quả sẽ sai, bạn thử điền một số vào ô AM10 (cột ngày 16 của sản phẩm B) sẽ thấy không ra kết quả. Vì đó là code của người khác nên mình không xem thêm nữa.
Dưới đây là code của mình để bạn tham khảo
Mã:
Option 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 Sub
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 đó.
Hình như hướng đi của bạn khác bạn maiban2068 ban đầu phải không?
Cám ơn bạn.
 

NhanSu

SMod
Thành viên BQT
@hocmoi code mình còn xóa thiếu các ô ở cột sau khi đã hết số lượng đơn hàng. Bạn download lại file . Mình cũng giải thích thêm trong file. Code của maiban mình chỉ xem qua nên không biết hướng đi có giống nhau không.
Mục đích của mình là đưa dữ liệu vào 2 bảng, một bảng từ cột V đến W, một bảng là 16 cột. Với mỗi dòng i của cùng mặt hàng A, mình chủ yếu xét từ cột kết thúc của dòng i-1 (lưu trong biến PrevCol), các ô phía trước cột này xóa bỏ. Biến tmp sẽ lưu số sản phẩm trong ngày sau khi đã trừ đi số lượng từ các dòng trên.
 

tuhocvba

Administrator
Thành viên BQT
1. Trước hết cảm ơn NhanSu đã phản hồi về cột cuối. Tôi thấy chỉ cần phản hồi về cột cuối và sửa ở đó là đủ. Không cần thiết phải viết lại toàn bộ code. Đó là việc dư thừa.
Với người như hocmoi khi đọc vấn đề như vậy có thể nghĩ code sai trầm trọng, trong khi đây không phải là vấn đề lớn.

2. Tôi không nghĩ có sự khác nhau nào ở đây về tốc độ. Cả hai đều sử dụng hai vòng lặp For. Chạy hàng, bên trong chạy cột. Đây chính là điểm chính liên quan tới tốc độ chương trình.

3. Một bên chia dữ liệu làm hai bảng (sử dung hai mảng) do cột W của chủ topic nằm ở giữa vùng dữ liệu, mà cột này thì lại muốn giữ nguyên. -NhanSu.
Một bên chỉ dùng một bảng (sử dụng một mảng) -> mất công thức -> vbano1 sử dụng thêm một mảng tái hiện lại công thức cho cột W.

4. Các xử lý của maiban2068 dùng tới TRIM, kiemtraso, tôi nghĩ là bạn ấy tính tới các khả năng mà hàm Isnumeric có thể sót trong vài tình huống không mong muốn.
Tôi rất tiếc là bạn maiban2068 đã bị xóa nick, cho nên không thể nói cho chúng ta biết.

Tôi nhận thức rằng topic này đã giải quyết xong. Topic sẽ Khóa.
 
Trạng thái
Không mở trả lời sau này.
Top