Xin giúp về Code VBA về việc tự động lọc và copy dữ liệu >0 tuần tự từng cột sang bảng mới

PeterVu

Thành viên mới
Tôi có 1 vấn đề khó giải quyết xin được các cao thủ chỉ giáo về code VBA
Vì hàng sản xuất thực tế có đến hàng trăm hàng, và hàng nghìn mã liệu nên copy thủ công từng hàng rất mất thời gian.
Nên tôi cần được hỗ trợ code VBA tự động có thể tự động lọc tuần tự "Số lượng liệu cần dùng" cho mỗi "Sản phẩm" lớn hơn 0. (Nếu bằng 0 thì bỏ qua).
Để cho code thông minh hơn thì đếm số cột, sau đấy khi lọc và copy đến cột cuối cùng sẽ dừng lại.

Sau khi lọc giá trị lớn hơn 0 cho những "Mã liệu" dùng trong sản phẩm thì Copy Mã liệu/ Lượng Dùng/Mô Tả/Sản Phẩm tương ứng sang 1 sheet khác nhưng có thay đổi về trình tự sắp xếp từ Ngang sang Dọc

Như ví dụ ở file đính kèm, Sản phẩm thứ nhất là "P2MB1" chỉ dùng đến Mã liệu: 651-04107-031, 2 mã còn lại không dùng. Thì dữ liệu đầu ra chỉ thể hiện (Xem phần Dữ liệu đầu ra)

1.) Dữ liệu đầu vào
Mô tảPre-BuildSticky
MLB
Reflow
MLB
MLB Fit Check
Sản phẩmP2MB1P2MS1P2MR1P2P1
Số lượng sản xuất14412642
Lượng DùngMã liệuTổng số lượng liệu cần dùng
1651-04107-031
204​
14412642
8150-00030-001
480​
09648336
2150-09499-001
120​
0241284

2.) Dữ liệu đầu ra

Mô tảSản phẩmSố lượng sản xuấtMã liệuLượng dùngTổng số lượng liệu cần dùng
Pre-BuildP2MB1144651-04107-031
1​
144​
Sticky MLBP2MS112651-04107-031
1​
12​
Sticky MLBP2MS112150-00030-001
8​
96​
Sticky MLBP2MS112150-09499-001
2​
24​
Reflow MLBP2MR16651-04107-031
1​
6​
Reflow MLBP2MR16150-00030-001
8​
48​
Reflow MLBP2MR16150-09499-001
2​
12​
MLB Fit CheckP2P142651-04107-031
1​
42​
MLB Fit CheckP2P142150-00030-001
8​
336​
MLB Fit CheckP2P142150-09499-001
2​
84​
 

thanhphong

Thành viên mới
Nội dung: Tra theo mã liệu ở sheet input "Đầu vào" lấy thông tin, nhập vào sheet output "Đầu ra".
Nhìn nội dung như trên thì phải hiểu mã liệu giống như mã số sinh viên, mã số hàng hóa-là số tồn tại duy nhất.

Tuy nhiên ứng với mỗi mã liệu sẽ có những Mô tả khác nhau, vì vậy khi ghi thông tin ra sheet output thì các dòng mã liệu sẽ thấy lặp lại nhiều lần..
Có điều tôi không hiểu (phần màu đỏ), bạn có thể bớt thời gian giải thích được không?
Câu hỏi:Tại sao mã 150-00030-001 P2MS1 lại là 12 mà không phải là 96?
Bạn cần đăng nhập để thấy hình ảnh
 

PeterVu

Thành viên mới
Nội dung: Tra theo mã liệu ở sheet input "Đầu vào" lấy thông tin, nhập vào sheet output "Đầu ra".
Nhìn nội dung như trên thì phải hiểu mã liệu giống như mã số sinh viên, mã số hàng hóa-là số tồn tại duy nhất.

Tuy nhiên ứng với mỗi mã liệu sẽ có những Mô tả khác nhau, vì vậy khi ghi thông tin ra sheet output thì các dòng mã liệu sẽ thấy lặp lại nhiều lần..
Có điều tôi không hiểu (phần màu đỏ), bạn có thể bớt thời gian giải thích được không?
Câu hỏi:Tại sao mã 150-00030-001 P2MS1 lại là 12 mà không phải là 96?
Bạn cần đăng nhập để thấy hình ảnh
Chào bạn. Rất cám ơn bạn đã dành thời gian quan tâm.
Sheet "Đầu Vào" Bạn để ý Cell E3 = 12, đây là số lượng cần sản xuất cho hàng P2MS1, và dùng lượng của mã 150-00030-001 là A6 = 8. Vì vậy để sản xuất 12 hàng P2MS1 cần 96 mã liệu 150-00030-001.
Khi đối chiếu sang sheet "Đầu Ra" bạn sẽ thấy 96 xuất hiện ở F4 = 96 thay vì C4 =12. Vì C4 =12 là số lượng cần sản xuất của sản phần P2MS1, tương ứng với E3 = 12 ở sheet "Đầu vào".
Nói cách khác ở Sheet "Đầu ra" F4 = 96 = E4 x C4
 

thanhphong

Thành viên mới
Vậy thì thuyết minh như bài #1 của bạn, người khác không hiểu được đâu.
Tôi tóm tắt như sau:
Bạn cần đăng nhập để thấy hình ảnh

Ai có thời gian thì giúp nhé.
Bài này không khó, dự kiến code mất 2h. Tôi không có thời gian cho bạn, nhưng có thể code giúp bạn. Nếu bạn đồng ý hỗ trợ diễn đàn số tiền 50k x 2h = 100k thì tôi sẽ code bài này.
 

PeterVu

Thành viên mới
Vậy thì thuyết minh như bài #1 của bạn, người khác không hiểu được đâu.
Tôi tóm tắt như sau:
Bạn cần đăng nhập để thấy hình ảnh

Ai có thời gian thì giúp nhé.
Bài này không khó, dự kiến code mất 2h. Tôi không có thời gian cho bạn, nhưng có thể code giúp bạn. Nếu bạn đồng ý hỗ trợ diễn đàn số tiền 50k x 2h = 100k thì tôi sẽ code bài này.
Cám ơn bạn cách mô tả rất chuyên nghiệp, đúng kết quả mình cần.
Mình cần thêm đoạn code nó có thể đếm tổng số cột sản phẩm, sau khi copy đến cột cuối cùng thì dừng lại. (Kiểu gán biến totalcolum = tổng số cột sản phẩm, khi copy cột thứ nhất = biến i, cột thứ 2 bằng i + 1, đến khi i + n = totalcolumn thì copy dữ liệu sang sheet đầu ra và dừng lại)
Bạn giúp nhé, ngoài việc 100K mình mời thêm bạn cốc cafe 50K. Thanks!
 
Sửa lần cuối:

thanhphong

Thành viên mới
OK, vậy tôi sẽ code.
1. Tôi nhận thức rằng diễn đàn sẽ nhận được số tiền ủng hộ của bạn là 150k.
2. Dưới đây là thỏa thuận:
- Để thuận tiện cho việc code, sau đây tôi sẽ sử dụng tên sheet là Input, Output.
Hiện trạng đang để tên sheet là tiếng việt có dấu "Đầu vào", "Đầu ra": Việc này không thuận tiện cho việc code.
Nếu thay đổi của tôi gây ảnh hưởng cho bạn, hãy phản hồi lại để tôi biết.
-Code sẽ đi theo hướng, số lượng sản phẩm tùy ý, tức là số cột ở sheet input không cố định.
Tuy nhiên, tôi nhận thức rằng các dòng 1~4 của sheet input là cố định.
Cũng như tên các cột 1~3 là cố định.
Bạn cần đăng nhập để thấy hình ảnh
 

PeterVu

Thành viên mới
OK, vậy tôi sẽ code.
1. Tôi nhận thức rằng diễn đàn sẽ nhận được số tiền ủng hộ của bạn là 150k.
2. Dưới đây là thỏa thuận:
- Để thuận tiện cho việc code, sau đây tôi sẽ sử dụng tên sheet là Input, Output.
Hiện trạng đang để tên sheet là tiếng việt có dấu "Đầu vào", "Đầu ra": Việc này không thuận tiện cho việc code.
Nếu thay đổi của tôi gây ảnh hưởng cho bạn, hãy phản hồi lại để tôi biết.
-Code sẽ đi theo hướng, số lượng sản phẩm tùy ý, tức là số cột ở sheet input không cố định.
Tuy nhiên, tôi nhận thức rằng các dòng 1~4 của sheet input là cố định.
Cũng như tên các cột 1~3 là cố định.
Bạn cần đăng nhập để thấy hình ảnh
+ Đã chuyển khoản:
+ Sheet name "Đầu vào" hay "Đầu Ra" có thể tùy ý thay đổi để thuận tiện cho code.
+ Đồng ý với đề xuất phía dưới:
-Code sẽ đi theo hướng, số lượng sản phẩm tùy ý, tức là số cột ở sheet input không cố định.
Tuy nhiên, tôi nhận thức rằng các dòng 1~4 của sheet input là cố định.
Cũng như tên các cột 1~3 là cố định.
 

thanhphong

Thành viên mới
OK, mình đang code. Cho mình xác nhận, sheet input, mã liệu trên mỗi dòng chỉ xuất hiện một lần. hay là có thể lặp lại mã liệu giống nhau trên các dòng khác ở sheet input?
Bạn cần đăng nhập để thấy hình ảnh
 

PeterVu

Thành viên mới
OK, mình đang code. Cho mình xác nhận, sheet input, mã liệu trên mỗi dòng chỉ xuất hiện một lần. hay là có thể lặp lại mã liệu giống nhau trên các dòng khác ở sheet input?
Bạn cần đăng nhập để thấy hình ảnh
Mã liệu ở cột B sheet "Input" chỉ xuất hiện 1 lần, không có trùng lặp.
 

thanhphong

Thành viên mới
1. Đầu tiên bạn đổi tên các sheet thành:
Input
Output
2. Tạo nút bấm trên sheet Output.
Code cho nút bấm là:
Mã:
Private Sub CommandButton1_Click()
    Call tinhtoan
End Sub
3. Tạo Module1, trên đó viết code:
Mã:
Sub tinhtoan()
    Dim arr As Variant
    Dim kq  As Variant
    Dim cnt As Long
    Dim i       As Long
    Dim j       As Long
    Dim rend    As Long 'Dong cuoi tren sheet input
    Dim cend    As Integer 'Cot cuoi cung tren sheet input
    Const sh1   As String = "Input"
    Const sh2   As String = "Output"
    Const r1    As Long = 4 'Dong tieu de tren sheet input
    Const c1    As Long = 3 'Cot mo ta, san pham, so luong san xuat- tren sheet input
    'Mo sheet input de gan gia tri
    ThisWorkbook.Sheets(sh1).Activate
    rend = ThisWorkbook.Sheets(sh1).Cells(Rows.Count, 1).End(xlUp).Row
    'Khong tim thay du lieu thi thoat chuong trinh
    If rend <= r1 Then
        MsgBox "Khong tim thay du lieu tren sheet Input"
        Exit Sub
    End If
   
    cend = ThisWorkbook.Sheets(sh1).Cells(1, Columns.Count).End(xlToLeft).Column
    If cend <= c1 Then
        MsgBox "Khong tim thay du lieu tren sheet Input"
        Exit Sub
    End If
   
    arr = ThisWorkbook.Sheets(sh1).Range(Cells(1, 1), Cells(rend, cend)).Value
    cnt = 0
 
    For i = c1 + 1 To UBound(arr, 2) Step 1 'Chay tu cot 4 den cot cuoi cung
        For j = r1 + 1 To UBound(arr, 1) Step 1
            'Neu luong can dung = 0 or "" thi khong lam viec
            If CStr(arr(j, i)) = "" Or Val(CStr(arr(j, i))) = 0 Then
            Else
                'Lam viec
                 cnt = cnt + 1
                 If cnt = 1 Then
                    ReDim kq(1 To 6, 1 To cnt)
                 Else
                    ReDim Preserve kq(1 To 6, 1 To cnt)
                 End If
                 kq(1, cnt) = CStr(arr(1, i)) 'Mo ta: Reflow MLB
                 kq(2, cnt) = CStr(arr(2, i)) 'San pham: P2MB1
                 kq(3, cnt) = CStr(arr(3, i)) 'So luong san xuat: 12
                 kq(4, cnt) = CStr(arr(j, 2)) 'Ma lieu: 150-09499-001
                 kq(5, cnt) = CStr(arr(j, 1)) 'Luong dung: 8
                 kq(6, cnt) = CStr(arr(j, i)) 'Tong so luong can dung: 96
            End If
        Next j
    Next i
    If cnt > 0 Then
        Call ghiketqua(sh2, kq)
        MsgBox "OK"
    End If
   
End Sub
Sub ghiketqua(ByVal sh As String, ByVal kq As Variant)
    Dim crr As Variant
    Dim rend2   As Long
   
    ThisWorkbook.Sheets(sh).Activate
   
    rend2 = ThisWorkbook.Sheets(sh).Cells(Rows.Count, 1).End(xlUp).Row
    If rend2 > 1 Then
        'Xoa du lieu truoc khi ghi ket qua
        ThisWorkbook.Sheets(sh).Range(Cells(2, 1), Cells(rend2, 6)).ClearContents
    End If
    crr = WorksheetFunction.Transpose(kq)
    'Ghi ket qua
    ThisWorkbook.Sheets(sh).Range(Cells(2, 1), Cells(UBound(crr, 1) + 1, 6)).Value = crr
End Sub
Cảm ơn bạn đã ủng hộ diễn đàn.
 

PeterVu

Thành viên mới
1. Đầu tiên bạn đổi tên các sheet thành:
Input
Output
2. Tạo nút bấm trên sheet Output.
Code cho nút bấm là:
Mã:
Private Sub CommandButton1_Click()
    Call tinhtoan
End Sub
3. Tạo Module1, trên đó viết code:
Mã:
Sub tinhtoan()
    Dim arr As Variant
    Dim kq  As Variant
    Dim cnt As Long
    Dim i       As Long
    Dim j       As Long
    Dim rend    As Long 'Dong cuoi tren sheet input
    Dim cend    As Integer 'Cot cuoi cung tren sheet input
    Const sh1   As String = "Input"
    Const sh2   As String = "Output"
    Const r1    As Long = 4 'Dong tieu de tren sheet input
    Const c1    As Long = 3 'Cot mo ta, san pham, so luong san xuat- tren sheet input
    'Mo sheet input de gan gia tri
    ThisWorkbook.Sheets(sh1).Activate
    rend = ThisWorkbook.Sheets(sh1).Cells(Rows.Count, 1).End(xlUp).Row
    'Khong tim thay du lieu thi thoat chuong trinh
    If rend <= r1 Then
        MsgBox "Khong tim thay du lieu tren sheet Input"
        Exit Sub
    End If
  
    cend = ThisWorkbook.Sheets(sh1).Cells(1, Columns.Count).End(xlToLeft).Column
    If cend <= c1 Then
        MsgBox "Khong tim thay du lieu tren sheet Input"
        Exit Sub
    End If
  
    arr = ThisWorkbook.Sheets(sh1).Range(Cells(1, 1), Cells(rend, cend)).Value
    cnt = 0

    For i = c1 + 1 To UBound(arr, 2) Step 1 'Chay tu cot 4 den cot cuoi cung
        For j = r1 + 1 To UBound(arr, 1) Step 1
            'Neu luong can dung = 0 or "" thi khong lam viec
            If CStr(arr(j, i)) = "" Or Val(CStr(arr(j, i))) = 0 Then
            Else
                'Lam viec
                 cnt = cnt + 1
                 If cnt = 1 Then
                    ReDim kq(1 To 6, 1 To cnt)
                 Else
                    ReDim Preserve kq(1 To 6, 1 To cnt)
                 End If
                 kq(1, cnt) = CStr(arr(1, i)) 'Mo ta: Reflow MLB
                 kq(2, cnt) = CStr(arr(2, i)) 'San pham: P2MB1
                 kq(3, cnt) = CStr(arr(3, i)) 'So luong san xuat: 12
                 kq(4, cnt) = CStr(arr(j, 2)) 'Ma lieu: 150-09499-001
                 kq(5, cnt) = CStr(arr(j, 1)) 'Luong dung: 8
                 kq(6, cnt) = CStr(arr(j, i)) 'Tong so luong can dung: 96
            End If
        Next j
    Next i
    If cnt > 0 Then
        Call ghiketqua(sh2, kq)
        MsgBox "OK"
    End If
  
End Sub
Sub ghiketqua(ByVal sh As String, ByVal kq As Variant)
    Dim crr As Variant
    Dim rend2   As Long
  
    ThisWorkbook.Sheets(sh).Activate
  
    rend2 = ThisWorkbook.Sheets(sh).Cells(Rows.Count, 1).End(xlUp).Row
    If rend2 > 1 Then
        'Xoa du lieu truoc khi ghi ket qua
        ThisWorkbook.Sheets(sh).Range(Cells(2, 1), Cells(rend2, 6)).ClearContents
    End If
    crr = WorksheetFunction.Transpose(kq)
    'Ghi ket qua
    ThisWorkbook.Sheets(sh).Range(Cells(2, 1), Cells(UBound(crr, 1) + 1, 6)).Value = crr
End Sub
Cảm ơn bạn đã ủng hộ diễn đàn.
Mình đã test và nhận được kết quả ngoài mong đợi. Code logic và rất chuyên nghiệp.
Mình sẽ tiếp tục ủng hộ diễn đàn. Chân thành cảm ơn.
 
Top