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

Yêu THVBA nhất
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​
 
T

thanhphong

Guest
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

Yêu THVBA nhất
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
 
T

thanhphong

Guest
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

Yêu THVBA nhất
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.
 
T

thanhphong

Guest
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

Yêu THVBA nhất
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.
 

Celine2023

Yêu THVBA
Không biết cao nhân chủ đề này còn ở đây không ạ ?
Em cũng có bảng tương tự nhưng chỉ cần chuyển đổi thành 3 cột dữ liệu. Em có chỉnh lại code cho phù hợp nhưng kết quả lại không ra được. Không biết lỗi ở chỗ nào mọi người xem giúp em với
1) Đầu vào :
code HQ1ARGOSSF05-5S8A1ARGOSSF05-A8A1ARGOSSF08-A82BID01-A8L
EN001 1.01069934 1.01069934 1.01069934 1.01069934
EN002 - - - -
PM001 1.00924448 1.00924448 1.00924448 -
PM0909011 - - - -
PM39211399 - - - -
RM001 1.02095760 1.02095760 - -
RM1103001 - - - -
VM001 1.06891799 1.06891799 1.06891799 1.06891799
CM2001001 0.05757524 0.05757524 0.05757524 0.05757524
PM0101000 0.00792088 0.00792088 0.00792088 0.00792088
PM0102000 - - - -
2) Đầu ra :
mã khai HQMã NPLđịnh mức
1ARGOSSF05-5S8AEN001 1.01069934096768
1ARGOSSF05-5S8APM001 1.00924448287173
1ARGOSSF05-5S8ARM001 1.02095759832189
1ARGOSSF05-5S8AVM001 1.06891799027139
1ARGOSSF05-5S8ACM2001001 0.05757524301074
1ARGOSSF05-5S8APM0101000 0.00792087963989
1ARGOSSF05-5S8APM0502000 0.02619404122559
1ARGOSSF05-5S8APM0301010 0.01549142924129
1ARGOSSF05-5S8APM0302010 0.00513853987840
1ARGOSSF05-5S8APM0305010 0.00683186864990
1ARGOSSF05-5S8APM0309010 0.00074659666197

Nhưng chuyển đổi code thì nó ra thành thế này : không có code NVL cũng ko có định mức

1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8

Code em chuyển :
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 = 1 'Dong tieu de tren sheet input
    Const c1    As Long = 1 '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 3, 1 To cnt)
                 Else
                    ReDim Preserve kq(1 To 3, 1 To cnt)
                 End If
                 kq(1, cnt) = CStr(arr(1, i)) 'Mo ta: Reflow MLB
                 kq(2, cnt) = CStr(arr(j, 1)) 'Ma lieu: 150-09499-001
                 kq(3, 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, 3)).ClearContents
    End If
    crr = WorksheetFunction.Transpose(kq)
    'Ghi ket qua
    ThisWorkbook.Sheets(sh).Range(Cells(2, 1), Cells(UBound(crr, 1) + 1, 3)).Value = crr
End Sub
 

dmsvietuc

Yêu THVBA
Không biết cao nhân chủ đề này còn ở đây không ạ ?
Em cũng có bảng tương tự nhưng chỉ cần chuyển đổi thành 3 cột dữ liệu. Em có chỉnh lại code cho phù hợp nhưng kết quả lại không ra được. Không biết lỗi ở chỗ nào mọi người xem giúp em với
1) Đầu vào :
code HQ1ARGOSSF05-5S8A1ARGOSSF05-A8A1ARGOSSF08-A82BID01-A8L
EN001 1.01069934 1.01069934 1.01069934 1.01069934
EN002 - - - -
PM001 1.00924448 1.00924448 1.00924448 -
PM0909011 - - - -
PM39211399 - - - -
RM001 1.02095760 1.02095760 - -
RM1103001 - - - -
VM001 1.06891799 1.06891799 1.06891799 1.06891799
CM2001001 0.05757524 0.05757524 0.05757524 0.05757524
PM0101000 0.00792088 0.00792088 0.00792088 0.00792088
PM0102000 - - - -
2) Đầu ra :
mã khai HQMã NPLđịnh mức
1ARGOSSF05-5S8AEN001 1.01069934096768
1ARGOSSF05-5S8APM001 1.00924448287173
1ARGOSSF05-5S8ARM001 1.02095759832189
1ARGOSSF05-5S8AVM001 1.06891799027139
1ARGOSSF05-5S8ACM2001001 0.05757524301074
1ARGOSSF05-5S8APM0101000 0.00792087963989
1ARGOSSF05-5S8APM0502000 0.02619404122559
1ARGOSSF05-5S8APM0301010 0.01549142924129
1ARGOSSF05-5S8APM0302010 0.00513853987840
1ARGOSSF05-5S8APM0305010 0.00683186864990
1ARGOSSF05-5S8APM0309010 0.00074659666197

Nhưng chuyển đổi code thì nó ra thành thế này : không có code NVL cũng ko có định mức

1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8
1ARGOSSF05-5S8A53VP08-M8A3SFSVSS2GY09-M8

Code em chuyển :

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 = 1 'Dong tieu de tren sheet input
Const c1 As Long = 1 '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 3, 1 To cnt)
Else
ReDim Preserve kq(1 To 3, 1 To cnt)
End If
kq(1, cnt) = CStr(arr(1, i)) 'Mo ta: Reflow MLB
kq(2, cnt) = CStr(arr(j, 1)) 'Ma lieu: 150-09499-001
kq(3, 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, 3)).ClearContents
End If
crr = WorksheetFunction.Transpose(kq)
'Ghi ket qua
ThisWorkbook.Sheets(sh).Range(Cells(2, 1), Cells(UBound(crr, 1) + 1, 3)).Value = crr
End Sub
Bạn gửi file vào hanamqs99@gmail.com tôi xem cho.
 
Top