VBA lọc dữ liệu theo danh sách có sẵn

[ngoctuyen1995]

Thân chào cả nhà GPEX,

Hiện tại em có file data bao gồm 3 sheet (Data, List_Dieukien, Ketqua).
Em muốn dùng VBA lọc danh sách ở Storecode Sheet Data tương ứng với StoreCode ở Sheet list_Dieukien và Copy sang sheet KetQua, vì số lượng cột data của em lên tới 1000 cột lựng ạ (Data em gửi demo thôi ạ).
Em có đính kèm file bên dưới

Mong cả nhà giúp đỡ em, em chân thành cảm ơn ạ.

 

[Hoàng Tuấn 868]

Em muốn dùng VBA lọc danh sách ở Storecode Sheet Data tương ứng với StoreCode ở Sheet list_Dieukien và Copy sang sheet KetQua, vì số lượng cột data của em lên tới 1000 cột lựng ạ (Data em gửi demo thôi ạ).

1000 cột là những cột nào bạn nhỉ?

 

[Maika8008]

Thân chào cả nhà GPEX,

Hiện tại em có file data bao gồm 3 sheet (Data, List_Dieukien, Ketqua).
Em muốn dùng VBA lọc danh sách ở Storecode Sheet Data tương ứng với StoreCode ở Sheet list_Dieukien và Copy sang sheet KetQua, vì số lượng cột data của em lên tới 1000 cột lựng ạ (Data em gửi demo thôi ạ).
Em có đính kèm file bên dưới

Mong cả nhà giúp đỡ em, em chân thành cảm ơn ạ.

Những cái StoreCode ở Sheet list_Dieukien đó xuất hiện nhiều lần trong sheet Data chứ đâu như trong ví dụ của bạn là mỗi cái chỉ xuất hiện 1 lần?

 

[ngoctuyen1995]

Những cái StoreCode ở Sheet list_Dieukien đó xuất hiện nhiều lần trong sheet Data chứ đâu như trong ví dụ của bạn là mỗi cái chỉ xuất hiện 1 lần?

Storecode chỉ có 1 thôi ạ

Bài đã được tự động gộp: 18/1/21

1000 cột là những cột nào bạn nhỉ?

cột chính thì chỉ những cột trong file của em, còn lại thì không quan trọng ạ

 

[Hoàng Tuấn 868]

Storecode chỉ có 1 thôi ạ

Bài đã được tự động gộp: 18/1/21

cột chính thì chỉ những cột trong file của em, còn lại thì không quan trọng ạ

Sau lại sửa vị trí sao? - Thêm một chút: Bạn nên bỏ chữ "Help" trên tiêu đề nhé (Vì nội qui không cho phép).

 

[ngoctuyen1995]

Sau lại sửa vị trí sao? - Thêm một chút: Bạn nên bỏ chữ "Help" trên tiêu đề nhé (Vì nội qui không cho phép).

cảm ơn Anh đã quan tâm ạ, em đã sửa lại chủ đề rồi ạ

 

[Maika8008]

cảm ơn Anh đã quan tâm ạ, em đã sửa lại chủ đề rồi ạ

Chú ý: người ta nêu 2 vấn đề, bạn chỉ đọc thấy có 1 hà!

 

[ngoctuyen1995]

Chú ý: người ta nêu 2 vấn đề, bạn chỉ đọc thấy có 1 hà!

không cần sửa vị trí ạ, chỉ cần copy được data dựa vào list đó là được ạ.

 

[Hoàng Tuấn 868]

Không cần sửa vị trí ạ, chỉ cần copy được data dựa vào list đó là được ạ.

Bạn tham khảo file..

 

[ngoctuyen1995]

Bạn tham khảo file..

Em cảm ơn anh ạ, code rất nhanh và đúng mục đích của em ạ.

Chúc anh Sức khỏe và Thành công ạ

 

[Ba Tê]

Bạn tham khảo file..

Dữ liệu ít thì không thấy gì.
Nếu dữ liệu lớn thì:

    For j = 1 To UBound(mdk, 1)      'ubound(mdk,1)= 1.000'
        For i = 1 To UBound(mn, 1)  'Ubound(mn,1)= 100.000'

Hai vòng For này sẽ phải duyệt qua 1.000.000 lần để xét IF...

 

[Hoàng Tuấn 868]

Dữ liệu ít thì không thấy gì.
Nếu dữ liệu lớn thì:

    For j = 1 To UBound(mdk, 1)      'ubound(mdk,1)= 1.000'
        For i = 1 To UBound(mn, 1)  'Ubound(mn,1)= 100.000'

Hai vòng For này sẽ phải duyệt qua 1.000.000 lần để xét IF...

Em cảm ơn anh, anh cho em hỏi trường hợp này thì nên sửa code như thế nào để hiệu quả hơn ạ, xin cảm ơn anh.

 

[Hoàng Nhật Phương]

Em cảm ơn anh, anh cho em hỏi trường hợp này thì nên sửa code như thế nào để hiệu quả hơn ạ, xin cảm ơn anh.

OT nghĩ có lẽ sử dụng Dic đưa các điều kiện trong 'List_DK' vào Dic sau đó kiểm tra theo Dic bạn à

 

[Ba Tê]

Em cảm ơn anh, anh cho em hỏi trường hợp này thì nên sửa code như thế nào để hiệu quả hơn ạ, xin cảm ơn anh.

Như ý bài #13, chạy 1 For ... Next đưa 1000 điều kiện vào Dictionary.
1 For ... Next duyệt 100.000 dữ liệu với IF.
100.000 IF so với 1.000.000 IF.

 

[Hoàng Nhật Phương]

Như ý bài #13, chạy 1 For ... Next đưa 1000 điều kiện vào Dictionary.
1 For ... Next duyệt 100.000 dữ liệu với IF.
100.000 IF so với 1.000.000 IF.

Như ý bài #14, Thầy đã góp ý, con thử code như sau, Thầy xem và góp ý thêm cho con với ạ.
Con cảm ơn Thầy.

Option Explicit

Public Sub TapCode()

    Dim sArr() As Variant, Dic As Object, sKey As String
    Dim r As Long, k As Long, j As Long, LastRow As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("List_DK")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If LastRow < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A2:A" & LastRow).Value2
        For r = 1 To UBound(sArr, 1)
           sKey = sArr(r, 1)
           If Not IsEmpty(sKey) And Not Dic.Exists(sKey) Then
                Dic.Add sKey, r
           End If
        Next r
    End With
 
    With Sheets("Data")
        LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        If LastRow < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A1:E" & LastRow).Value2
   End With
  
    r = UBound(sArr, 1): j = UBound(sArr, 2)
    ReDim result(1 To r, 1 To j)
    k = 1
    For r = 2 To UBound(sArr, 1)
       sKey = sArr(r, 3)
       If Not IsEmpty(sKey) Then
        If Dic.Exists(sKey) Then
            k = k + 1
            For j = 1 To UBound(sArr, 2)
                result(k, j) = sArr(r, j)
            Next j
        End If
       End If
    Next r
        
    With Sheets("KetQua")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(LastRow, UBound(result, 2)).ClearContents
        If k Then
            For j = 1 To UBound(sArr, 2)
                result(1, j) = sArr(1, j)
            Next j
            .Range("A1").Resize(k, UBound(result, 2)) = result
        Else
            MsgBox "Khong tim thay ket qua trung khop", vbInformation
        End If
    End With
    
End_sub:
Set Dic = Nothing

End Sub

 

[Ba Tê]

Như ý bài #14, Thầy đã góp ý, con thử code như sau, Thầy xem và góp ý thêm cho con với ạ.
Con cảm ơn Thầy.

Option Explicit

Public Sub TapCode()

    Dim sArr() As Variant, Dic As Object, sKey As String
    Dim r As Long, k As Long, j As Long, LastRow As Long
    Set Dic = CreateObject("Scripting.Dictionary")
 
    With Sheets("List_DK")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If LastRow < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A2:A" & LastRow).Value2
        For r = 1 To UBound(sArr, 1)
           sKey = sArr(r, 1)
           If Not IsEmpty(sKey) And Not Dic.Exists(sKey) Then
                Dic.Add sKey, r
           End If
        Next r
    End With

    With Sheets("Data")
        LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        If LastRow < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A1:E" & LastRow).Value2
   End With

    r = UBound(sArr, 1): j = UBound(sArr, 2)
    ReDim result(1 To r, 1 To j)
    k = 1
    For r = 2 To UBound(sArr, 1)
       sKey = sArr(r, 3)
       If Not IsEmpty(sKey) Then
        If Dic.Exists(sKey) Then
            k = k + 1
            For j = 1 To UBound(sArr, 2)
                result(k, j) = sArr(r, j)
            Next j
        End If
       End If
    Next r
     
    With Sheets("KetQua")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(LastRow, UBound(result, 2)).ClearContents
        If k Then
            For j = 1 To UBound(sArr, 2)
                result(1, j) = sArr(1, j)
            Next j
            .Range("A1").Resize(k, UBound(result, 2)) = result
        Else
            MsgBox "Khong tim thay ket qua trung khop", vbInformation
        End If
    End With
 
End_sub:
Set Dic = Nothing

End Sub

If k Then
            'For j = 1 To UBound(sArr, 2)'
                'result(1, j) = sArr(1, j)'
            'Next j'
            .Range("A1").Resize(k, UBound(result, 2)) = result
        Else
            MsgBox "Khong tim thay ket qua trung khop", vbInformation
        End If

Vòng lặp For J để làm gì? Có thể lấy tiêu đề cột từ vòng For bên trên luôn mà.

 

[Hoàng Nhật Phương]

If k Then
            'For j = 1 To UBound(sArr, 2)'
                'result(1, j) = sArr(1, j)'
            'Next j'
            .Range("A1").Resize(k, UBound(result, 2)) = result
        Else
            MsgBox "Khong tim thay ket qua trung khop", vbInformation
        End If

Vòng lặp For J để làm gì?

Ui, đúng là đoạn này thừa Thầy ạ.
Vì mải mê khi con gán k=1 từ đầu nên con không nghĩ là gán luôn mảng kết quả là 1 thay vì k (tận dụng luôn vòng lặp J ở trên)
Hâyzaa, tư duy của con vẫn không khá lên được hic.
Con cảm ơn Thầy nhiều ạ.

 

[BuiQuangThuan]

Như ý bài #13, chạy 1 For ... Next đưa 1000 điều kiện vào Dictionary.
1 For ... Next duyệt 100.000 dữ liệu với IF.
100.000 IF so với 1.000.000 IF.

Sub XYZ()
    Dim Arr(), Res(), Dic As Object
    Dim i&, K&, j&, Nguon()
Set Dic = CreateObject("scripting.dictionary")
Nguon = Sheet2.Range("A2:A" & Sheet2.Range("A" & Rows.Count).End(3).Row).Value
Arr = Sheet1.Range("A2:E" & Sheet1.Range("C" & Rows.Count).End(3).Row).Value
ReDim Res(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Nguon, 1)
    If Dic.Exists(Nguon(i, 1)) = False Then
        Dic.Item(Nguon(i, 1)) = i
    End If
Next
For i = 1 To UBound(Arr, 1)
    If Dic.Exists(Arr(i, 3)) Then
        K = K + 1
        For j = 1 To UBound(Arr, 2)
            Res(K, j) = Arr(i, j)
        Next j
    End If
Next
Sheets("KetQua").Range("A2").Resize(10000, UBound(Arr, 2)).ClearContents
If K Then Sheets("KetQua").Range("A2").Resize(K, UBound(Arr, 2)) = Res
End Sub

Nhờ chú có thể chỉ giúp cháu với đoạn code trên có sai gì về cấu trúc không ạ. Tại cháu mới học về Dictionary

 

[ptm0412]

Dữ liệu ít thì không thấy gì.
Nếu dữ liệu lớn thì:

    For j = 1 To UBound(mdk, 1)      'ubound(mdk,1)= 1.000'
        For i = 1 To UBound(mn, 1)  'Ubound(mn,1)= 100.000'

Hai vòng For này sẽ phải duyệt qua 1.000.000 lần để xét IF...

Một trăm triệu chứ anh?

 

[Hoàng Tuấn 868]

OT nghĩ có lẽ sử dụng Dic đưa các điều kiện trong 'List_DK' vào Dic sau đó kiểm tra theo Dic bạn à

Xin cảm ơn OT đã góp ý, mình sẽ thử xem thế nào.

Bài đã được tự động gộp: 20/1/21

Như ý bài #13, chạy 1 For ... Next đưa 1000 điều kiện vào Dictionary.
1 For ... Next duyệt 100.000 dữ liệu với IF.
100.000 IF so với 1.000.000 IF.

Em cảm ơn anh, em sẽ nghiên cứu để áp dụng ạ, em mới biết VBA được vài tháng nên còn phải rút kinh nghiệm và học hỏi thêm nhiều. Chân thành cảm ơn anh.