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 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ì? Có thể lấy tiêu đề cột từ vòng For bên trên luôn mà.

Con chào Thầy, giờ con mới ngồi phân tích lại đã hiểu vì sao con tách vòng For J ở dưới nữa và đặt điều kiện khi thỏa mãn mảng kết quả có giá trị.
Con không gán luôn vào vòng for J ở trên là vì vòng for này nằm trong For r nên mỗi r khi thỏa mãn nó sẽ chạy lại cái tiêu đề như vậy sẽ lặp lại, do vậy con mới tách riêng, Thầy chỉ con cách giảm vòng for J ở dưới mà tiêu để không lặp lại với ạ, con chưa biết cách xử lý tình huống này.

Ngoài ra con thấy nếu có chuyển được vào 1 vòng for J ở trên hay mở thêm một for J ở dưới như con đã làm thì số vòng lặp vẫn như nhau phải không Thầy, mà chỉ là code nó dài thêm một vòng for J nữa nên nhìn code nó dài ạ.

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

Con chào chú Mỹ nhé, hehe.

 

[HieuCD]

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

r = UBound(sArr, 1): j = UBound(sArr, 2)
Nên tạo thêm biến riêng khi dùng nhiều lần
sRow = UBound(sArr, 1): sCol= UBound(sArr, 2)

Đã xét điều kiện Not isempty
If Not IsEmpty(sKey) And Not Dic.Exists(sKey) Then
Dic.Add sKey, r
Không cần xét thêm điều kiện: If Not IsEmpty(sKey) Then

Các cột dữ liệu và kết quả giống nhau, dùng mảng dữ liệu là mảng kết quả

    sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
    ......
    k = 1
    For r = 2 To sRow         
        If Dic.Exists(sArr(r, 3) ) Then
            k = k + 1
            For j = 1 To sCol
                sArr(k, j) = sArr(r, j)
            Next j       
       End If
    Next

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

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

Code chạy tốt với dữ liệu trong file, tuy nhiên cần lường trước các khả năng có thể làm code chạy sai hoặc không chạy được
1/ Không có dữ liệu
2/ Dữ liệu empty
Tự chỉnh lại nếu thích

 

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

r = UBound(sArr, 1): j = UBound(sArr, 2)
Nên tạo thêm biến riêng khi dùng nhiều lần
sRow = UBound(sArr, 1): sCol= UBound(sArr, 2)

Đã xét điều kiện Not isempty
If Not IsEmpty(sKey) And Not Dic.Exists(sKey) Then
Dic.Add sKey, r
Không cần xét thêm điều kiện: If Not IsEmpty(sKey) Then

Các cột dữ liệu và kết quả giống nhau, dùng mảng dữ liệu là mảng kết quả

    sRow = UBound(sArr, 1): sCol = UBound(sArr, 2)
    ......
    k = 1
    For r = 2 To sRow        
        If Dic.Exists(sArr(r, 3) ) Then
            k = k + 1
            For j = 1 To sCol
                sArr(k, j) = sArr(r, j)
            Next j      
       End If
    Next

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

Code chạy tốt với dữ liệu trong file, tuy nhiên cần lường trước các khả năng có thể làm code chạy sai hoặc không chạy được
1/ Không có dữ liệu
2/ Dữ liệu empty
Tự chỉnh lại nếu thích

Dưới sự chỉ dẫn của Thầy @Ba Tê bỏ For J phía dưới mà khỏi phải lặp lại chỗ nào luôn về cái tiêu đề ạ và sự chỉ dẫn của Bác @HieuCD bỏ 1 mảng,1 if...
Con sửa lại code như sau, nhìn có vẻ không còn thể tối ưu hơn được nữa, Chú Mỹ @ptm0412 nhờ

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, d1 As Long, d2 As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("List_DK")
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        If r < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A2:A" & r).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")
        r = .Cells(.Rows.Count, "C").End(xlUp).Row
        If r < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A1:E" & r).Value2
    End With
    d1 = UBound(sArr, 1): d2 = UBound(sArr, 2): k = 1
    For r = 2 To d1
        sKey = sArr(r, 3)
        If Dic.Exists(sKey) Then
            k = k + 1
            For j = 1 To d2
                sArr(k, j) = sArr(r, j)
            Next j
        End If
    Next r
        
    With Sheets("KetQua")
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(r, d2).ClearContents
        If k Then
            .Range("A1").Resize(k, d2) = sArr
        Else
            MsgBox "Khong tim thay ket qua trung khop", vbInformation
        End If
    End With
    
End_sub:
    Set Dic = Nothing

End Sub

 

[Maika8008]

Dưới sự chỉ dẫn của Thầy @Ba Tê bỏ For J phía dưới mà khỏi phải lặp lại chỗ nào luôn về cái tiêu đề ạ và sự chỉ dẫn của Bác @HieuCD bỏ 1 mảng,1 if...
Con sửa lại code như sau, nhìn có vẻ không còn thể tối ưu hơn được nữa, Chú Mỹ @ptm0412 nhờ

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, d1 As Long, d2 As Long
    Set Dic = CreateObject("Scripting.Dictionary")
   
    With Sheets("List_DK")
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        If r < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A2:A" & r).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")
        r = .Cells(.Rows.Count, "C").End(xlUp).Row
        If r < 2 Then
            MsgBox "Khong tim thay du lieu trong sheet " & .Name, vbCritical
            GoTo End_sub
        End If
        sArr = .Range("A1:E" & r).Value2
    End With
    d1 = UBound(sArr, 1): d2 = UBound(sArr, 2): k = 1
    For r = 2 To d1
        sKey = sArr(r, 3)
        If Dic.Exists(sKey) Then
            k = k + 1
            For j = 1 To d2
                sArr(k, j) = sArr(r, j)
            Next j
        End If
    Next r
       
    With Sheets("KetQua")
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1").Resize(r, d2).ClearContents
        If k Then
            .Range("A1").Resize(k, d2) = sArr
        Else
            MsgBox "Khong tim thay ket qua trung khop", vbInformation
        End If
    End With
   
End_sub:
    Set Dic = Nothing

End Sub

OT cũng chịu khó ghê hé

 

[Hoàng Tuấn 868]

With Sheets("KetQua")
r = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1").Resize(r, d2).ClearContents
If k Then
.Range("A1").Resize(k, d2) = sArr
Else
MsgBox "Khong tim thay ket qua trung khop", vbInformation
End If
End With

OT cho mình hỏi: Dòng "if k then" trong đoạn code trên thì hiểu như thế nào nhỉ, bạn giải thích giúp nhé. Xin cảm ơn OT.

 

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

OT cho mình hỏi: Dòng "if k then" trong đoạn code trên thì hiểu như thế nào nhỉ, bạn giải thích giúp nhé. Xin cảm ơn OT.

À xin lỗi bạn chỗ này phải sửa lại là if K>1 mới đúng vì khi k chưa chạy trong for k đã bằng 1 rồi.
OT xử lý nếu thỏa mãn điều kiện khi dữ liệu trong sheet data có cac dòng dữ liệu trùng với từ khóa trong sheet điều kiện thì mới gán mảng xuống, nếu mảng ko có dữ liệu hoặc dữ liệu không theo ý khi sử dụng một mảng dữ liệu và kết quả chung nhau do đó nếu không bắt lỗi này thì có thể kết quả sẽ sai ạ.
Cảm ơn Bạn

 

[Hoàng Tuấn 868]

À xin lỗi bạn chỗ này phải sửa lại là if K>1 mới đúng vì khi k chưa chạy trong for k đã bằng 1 rồi.
OT xử lý nếu thỏa mãn điều kiện khi dữ liệu trong sheet data có cac dòng dữ liệu trùng với từ khóa trong sheet điều kiện thì mới gán mảng xuống, nếu mảng ko có dữ liệu hoặc dữ liệu không theo ý khi sử dụng một mảng dữ liệu và kết quả chung nhau do đó nếu không bắt lỗi này thì có thể kết quả sẽ sai ạ.
Cảm ơn Bạn

Mình chưa biết trường hợp này nên mới hỏi, bình thường thì hay thấy sau if thì là biểu thức so sánh nào đấy, nhưng lần này không thấy nên tò mò, bây giờ nhờ OT giải thích nên biết thêm. Cảm ơn OT nhiều nhé.

 

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

Mình chưa biết trường hợp này nên mới hỏi, bình thường thì hay thấy sau if thì là biểu thức so sánh nào đấy, nhưng lần này không thấy nên tò mò, bây giờ nhờ OT giải thích nên biết thêm. Cảm ơn OT nhiều nhé.

Ah Bạn, if k then sẽ hiểu là nếu K <>0 ạ.
Do OT lấy cả tiêu đề nên phải sửa lại là if k >1 bạn ạ.

 

[Hoàng Tuấn 868]

Ah Bạn, if k then sẽ hiểu là nếu K <>0 ạ.
Do OT lấy cả tiêu đề nên phải sửa lại là if k >1 bạn ạ.

Vậy là if k then là cách viết tắt của if k <> 0 then nhỉ, cảm ơn OT nhé.

 

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

Vậy là if k then là cách viết tắt của if k <> 0 then nhỉ, cảm ơn OT nhé.

Dạ đúng như vậy Bạn ạ.
If <> 0 là True, =0 là false ạ.

 

[Ba Tê]

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

Tôi thấy cũng ổn, chỉ có điều 2 "trường phái" code khác nhau nên khai báo i&, k&, j& ... tôi không hiểu lắm và cũng không muốn nhớ.
Khi xác định được số dòng, số cột của mảng thì nên đưa nó vào 1 biến (ví dụ R là số dòng, C là số cột), sau này dùng R, C thay cho dùng Ubound(Arr,1), Ubound(Arr,2) nhiều lần.

 

[ptm0412]

Do OT lấy cả tiêu đề nên phải sửa lại là if k >1 bạn ạ.

Câu lệnh chính cần làm là [A1].Resize(k, Col) = Result
- Nếu không lấy tiêu đề thì khi k = 0, Resize 0 bị lỗi, nên mới cần If k > 0
- Nếu có tiêu đề thì k luôn luôn > 0, Resize không bao giờ lỗi, if làm gì cho mệt? Người dùng thấy xuống kết quả trắng trơn (trừ dòng tiêu đề) là biết rồi.

Xét kỹ hơn nữa, thì cũng chả mắc gì mà phải lấy cả tiêu đề. Tiêu đề kết quả phải luôn luôn tồn tại sẵn chứ không phải mỗi lần mỗi xoá rồi thêm 1 vòng lặp 1000 cột lấy 1000 tiêu đề.

 

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

.. chứ không phải mỗi lần mỗi xoá rồi thêm 1 vòng lặp 1000 cột lấy 1000 tiêu đề.

A! con chào chú Mỹ,
Ơ code tại bài #23 của con làm gì có chỗ nào vòng lặp lấy tiêu đề nữa đâu chú Mỹ,còn code bài #15 vòng lặp cũng chỉ có rẹt một lần thôi mà. hic hic

 

[ptm0412]

A! con chào chú Mỹ,
Ơ code tại bài #23 của con làm gì có chỗ nào vòng lặp lấy tiêu đề nữa đâu chú Mỹ,còn code bài #15 vòng lặp cũng chỉ có rẹt một lần thôi mà. hic hic

Code 15: rẹt 1 lần nhưng 1 lần 1000 cột cho mỗi lần chạy
Code 23: Xoá từ A1, gán xuống A1, nếu không có tiêu đề là không hề có luôn trên đời

 

[tranhungdao12a3]

Tạo 3 bảng dựa trên 3 sheet, sau đó relationship dựa vào storecode là khoá. Sử dụng hàm Related để lấy kết quả. Bạn có thể chạy một hai trăm triệu dòng cũng không vấn đề gì.