Check đơn hàng input vào so với số lượng còn lại để sản xuất.

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

hocmoi

Yêu THVBA
Xin chào các thành viên diễn đàn.
Trước tiên mình xin cám ơn các thành viên đã hỗ trợ mình các đề tài trước đó.
Hôm nay mình có 1 vấn đề này , nhờ diễn đàn hỗ trợ dùm.
Vấn đề của mình: Mình có File quản lý muốn check đơn hàng input vào có phù hợp không để mình tính toán số lượng sản xuất. Mình có diễn giải trong hình kèm theo, mong nhận được sự hỗ trợ từ các thành viên.

Input:
Bạn cần đăng nhập để thấy hình ảnh

Output:
Bạn cần đăng nhập để thấy hình ảnh

Xin cám ơn.
P/S: Mình có đọc sự kiện vinh danh của diễn đàn, mình thấy rất ý nghĩa, và mình chắc khó lòng bằng các bạn đó. Chúc diễn đàn ngày càng vững mạnh và cho mình góp chút ít "kinh phi" cho diễn đàn trong sự kiện vinh danh này. Tuy không nhiều lắm nhưng có thể mời các bạn ly cafe.
 

giaiphapvba

Administrator
Thành viên BQT
Cảm ơn bạn @hocmoi . Topic của bạn đã dễ hiểu. Sau đây các thành viên sẽ hỗ trợ cho bạn.
Về việc , hiện tại diễn đàn đã tổ chức bầu chọn và trao thưởng xong. Nếu bạn có nhã ý ủng hộ, bạn có thể chuyển vào :
Thông tin ủng hộ diễn đàn:
Tài khoản Ngân hàng thương mại cổ phần Ngoại thương Việt Nam Vietcombank, số tài khoản: 0011003264055
Chi nhánh Quận Hoàn Kiếm, Hà Nội.
Chủ tài khoản: Phạm Minh Hoàng.

Số tiền sẽ được sử dụng vào lần vinh danh cuối năm nay (dự kiến tháng 12/2020).
Cảm ơn bạn.
 

hocmoi

Yêu THVBA
Ah, mình còn sót chỗ trường hợp 2: Khi phát hiện thiếu thì tô màu , sau khi chạy xong chuơng trình, mình sẽ cập nhật lại số lượng Input vào và chạy lại lần nữa thì nếu số lượng input = số lượng đáp ứng thì dòng tô màu đó sẽ mất màu nha.
 

BKKBG

Yêu THVBA nhất
Bạn chạy thủ tục sau: tuhocvba175

Mã:
'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
    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
    End With
    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
    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
Kết quả macro:
INPUT:
Bạn cần đăng nhập để thấy hình ảnh
OUTPUT:
Bạn cần đăng nhập để thấy hình ảnh

Diễn giải logic:
Cột cuối được xác định là cột cuối cùng chứa dữ liệu của dòng 1 (rstart):
Bạn cần đăng nhập để thấy hình ảnh
Dòng cuối được xác định là dòng chứa dữ liệu cuối cùng của cột V:
Bạn cần đăng nhập để thấy hình ảnh
Định nghĩa sản phẩm:
Bạn cần đăng nhập để thấy hình ảnh
Cột W chứa dữ liệu nhưng cột V không chứa dữ liệu thì dòng đó xác định là mang thông tin sản phẩm.
 

hocmoi

Yêu THVBA
Bạn chạy thủ tục sau: tuhocvba175

Mã:
'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
    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
    End With
    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
    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
Kết quả macro:
INPUT:
Bạn cần đăng nhập để thấy hình ảnh
OUTPUT:
Bạn cần đăng nhập để thấy hình ảnh

Diễn giải logic:
Cột cuối được xác định là cột cuối cùng chứa dữ liệu của dòng 1 (rstart):
Bạn cần đăng nhập để thấy hình ảnh
Dòng cuối được xác định là dòng chứa dữ liệu cuối cùng của cột V:
Bạn cần đăng nhập để thấy hình ảnh
Định nghĩa sản phẩm:
Bạn cần đăng nhập để thấy hình ảnh
Cột W chứa dữ liệu nhưng cột V không chứa dữ liệu thì dòng đó xác định là mang thông tin sản phẩm.
Cám ơn bạn BKKBG, code của bạn Ok, mình đang Test, nhưng 1 chỗ mình quên nói ( sơ ý), dưới mỗi SP A là dòng chứa công thức, bạn có thể lưu lại công thức đó dùm mình với, chỗ mình khoanh vùng màu đỏ,
Bạn cần đăng nhập để thấy hình ảnh

Mình cám ơn.
 

vbano1

SMod
Thành viên BQT
Vấn đề này bạn hỏi một lần rồi thì phải. Cách sửa tương tự như :
Bạn thử:
Mã:
'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
 

hocmoi

Yêu THVBA
Vấn đề này bạn hỏi một lần rồi thì phải. Cách sửa tương tự như :
Bạn thử:
Mã:
'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
Ok, cám ơn các bạn, mình đã Test Ok.
 
Trạng thái
Không mở trả lời sau này.
Top