[Giúp đỡ VBA] Lọc ra khách hàng trùng nhau tối thiểu trong 2 sheet

thanhphuongvip · 27/3/19

Xin chào anh em!
Mình có một file Excel danh sách rất nhiều khách hàng, được phân loại thành nhiều sheet theo theo mỗi loại khác nhau như QUYEN, Wall Street, Vstar chool, Star school,.... (Ở đây mình ví dụ có 4 sheet, thực tế có thể hơn)

1 khách hàng (được tính bằng số điện thoại - Cột D) có thể xuất hiện trong 1 hoặc nhiều sheet!

Bây giờ mình muốn lọc ra danh sách khách hàng (bao gồm tất cả các cột) bị trùng lặp trong tối thiểu 2 sheet bất kỳ trở lên và trích xuất ra một sheet mới. và ở sheet mới thêm một cột ghi chú là trùng ở mấy sheet, ví dụ trùng 2 thì ghi số 2, trùng 3 là ghi số 3,....

Mục đích cuối cùng là để lọc ra những khách hàng trùng nhau ở các sheet, càng thỏa nhiều sheet thì chứng tỏ khách đó càng VIP.

Mình có gửi file ví dụ lên đây, mong anh chị em giúp đỡ. Cảm ơn rất nhiều!

snow25 · 27/3/19

thanhphuongvip đã viết:
Xin chào anh em!
Mình có một file Excel danh sách rất nhiều khách hàng, được phân loại thành nhiều sheet theo theo mỗi loại khác nhau như QUYEN, Wall Street, Vstar chool, Star school,.... (Ở đây mình ví dụ có 4 sheet, thực tế có thể hơn)

1 khách hàng (được tính bằng số điện thoại - Cột D) có thể xuất hiện trong 1 hoặc nhiều sheet!

Bây giờ mình muốn lọc ra danh sách khách hàng (bao gồm tất cả các cột) bị trùng lặp trong tối thiểu 2 sheet bất kỳ trở lên và trích xuất ra một sheet mới. và ở sheet mới thêm một cột ghi chú là trùng ở mấy sheet, ví dụ trùng 2 thì ghi số 2, trùng 3 là ghi số 3,....

Mục đích cuối cùng là để lọc ra những khách hàng trùng nhau ở các sheet, càng thỏa nhiều sheet thì chứng tỏ khách đó càng VIP.

Mình có gửi file ví dụ lên đây, mong anh chị em giúp đỡ. Cảm ơn rất nhiều!

Bạn chạy code này xem đúng không nhé.

Mã:

Sub locdulieu()
    Dim sh As Worksheet, arr, arr1(1 To 5000, 1 To 2), dic As Object, i As Long, lr As Long, ten As String, a As Long, b As Long, c As Long
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TongHop" Then
           lr = sh.Range("D" & Rows.Count).End(xlUp).Row
              If lr > 1 Then
                 arr = sh.Range("D2:D" & lr).Value
                 For i = 1 To UBound(arr, 1)
                     If Not dic.exists(arr(i, 1)) Then
                        dic.Add arr(i, 1), Array(1, "#" & sh.Name & "#")
                     Else
                        ten = dic.Item(arr(i, 1))(1)
                        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
                           ten = ten & sh.Name & "#"
                           b = dic.Item(arr(i, 1))(0)
                           If b = 1 Then
                              a = a + 1
                              arr1(a, 1) = arr(i, 1)
                              arr1(a, 2) = 2
                              b = b + 1
                              dic.Item(arr(i, 1)) = Array(b, ten, a)
                           Else
                              c = dic.Item(arr(i, 1))(2)
                              arr1(c, 2) = arr1(c, 2) + 1
                           End If
                      End If
                   End If
                Next i
           End If
       End If
  Next
  With Sheets("Tonghop")
       .Cells.ClearContents
       If a Then .Range("A1").Resize(a, 2).Value = arr1
  End With
End Sub

thanhphuongvip · 27/3/19

snow25 đã viết:

Bạn chạy code này xem đúng không nhé.

Mã:

Sub locdulieu()
    Dim sh As Worksheet, arr, arr1(1 To 5000, 1 To 2), dic As Object, i As Long, lr As Long, ten As String, a As Long, b As Long, c As Long
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TongHop" Then
           lr = sh.Range("D" & Rows.Count).End(xlUp).Row
              If lr > 1 Then
                 arr = sh.Range("D2:D" & lr).Value
                 For i = 1 To UBound(arr, 1)
                     If Not dic.exists(arr(i, 1)) Then
                        dic.Add arr(i, 1), Array(1, "#" & sh.Name & "#")
                     Else
                        ten = dic.Item(arr(i, 1))(1)
                        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
                           ten = ten & sh.Name & "#"
                           b = dic.Item(arr(i, 1))(0)
                           If b = 1 Then
                              a = a + 1
                              arr1(a, 1) = arr(i, 1)
                              arr1(a, 2) = 2
                              b = b + 1
                              dic.Item(arr(i, 1)) = Array(b, ten, a)
                           Else
                              c = dic.Item(arr(i, 1))(2)
                              arr1(c, 2) = arr1(c, 2) + 1
                           End If
                      End If
                   End If
                Next i
           End If
       End If
  Next
  With Sheets("Tonghop")
       .Cells.ClearContents
       If a Then .Range("A1").Resize(a, 2).Value = arr1
  End With
End Sub

Ra kết quả đúng luôn bạn Snow25. Cảm ơn bạn nhé!
Mà mình muốn trong bảng kết quả hiển thị tất các cột như trong các sheet đc ko (thay vì chỉ có cột số đt).
Mục đích để lấy thông tin của người đó luôn cho tiện chứ khỏi cần tra lại các sheet kia.

snow25 · 27/3/19

thanhphuongvip đã viết:
Ra kết quả đúng luôn bạn Snow25. Cảm ơn bạn nhé!
Mà mình muốn trong bảng kết quả hiển thị tất các cột như trong các sheet đc ko (thay vì chỉ có cột số đt).
Mục đích để lấy thông tin của người đó luôn cho tiện chứ khỏi cần tra lại các sheet kia.

Vậy bạn cho mình cái mẫu mình xem nào.

.

thanhphuongvip · 27/3/19

Kiểu như này: Lấy lại hết các cột theo bảng cũ, thêm cột cuối là số lần lặp lại thôi

snow25 · 27/3/19

thanhphuongvip đã viết:
Kiểu như này: Lấy lại hết các cột theo bảng cũ, thêm cột cuối là số lần lặp lại thôi

View attachment 214127

Bạn chạy thửu code này nhé.

Mã:

Sub locdulieu()
    Dim sh As Worksheet, j As Long, arr, arr1(1 To 5000, 1 To 15), dic As Object, i As Long, lr As Long, ten As String, a As Long, b As Long, c As Long
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TongHop" Then
           lr = sh.Range("D" & Rows.Count).End(xlUp).Row
              If lr > 1 Then
                 arr = sh.Range("A2:N" & lr).Value
                 For i = 1 To UBound(arr, 1)
                     If Not dic.exists(arr(i, 4)) Then
                        dic.Add arr(i, 4), Array(1, "#" & sh.Name & "#")
                     Else
                        ten = dic.Item(arr(i, 4))(1)
                        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
                           ten = ten & sh.Name & "#"
                           b = dic.Item(arr(i, 4))(0)
                           If b = 1 Then
                              a = a + 1
                              For j = 1 To 14
                                  arr1(a, j) = arr(i, j)
                              Next j
                              arr1(a, 15) = 2
                              b = b + 1
                              dic.Item(arr(i, 4)) = Array(b, ten, a)
                           Else
                              c = dic.Item(arr(i, 4))(2)
                              arr1(c, 15) = arr1(c, 15) + 1
                           End If
                      End If
                   End If
                Next i
           End If
       End If
  Next
  With Sheets("Tonghop")
       .Cells.ClearContents
       If a Then .Range("A1").Resize(a, 15).Value = arr1
  End With
End Sub

thanhphuongvip · 27/3/19

snow25 đã viết:

Bạn chạy thửu code này nhé.

Mã:

Sub locdulieu()
    Dim sh As Worksheet, j As Long, arr, arr1(1 To 5000, 1 To 15), dic As Object, i As Long, lr As Long, ten As String, a As Long, b As Long, c As Long
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TongHop" Then
           lr = sh.Range("D" & Rows.Count).End(xlUp).Row
              If lr > 1 Then
                 arr = sh.Range("A2:N" & lr).Value
                 For i = 1 To UBound(arr, 1)
                     If Not dic.exists(arr(i, 4)) Then
                        dic.Add arr(i, 4), Array(1, "#" & sh.Name & "#")
                     Else
                        ten = dic.Item(arr(i, 4))(1)
                        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
                           ten = ten & sh.Name & "#"
                           b = dic.Item(arr(i, 4))(0)
                           If b = 1 Then
                              a = a + 1
                              For j = 1 To 14
                                  arr1(a, j) = arr(i, j)
                              Next j
                              arr1(a, 15) = 2
                              b = b + 1
                              dic.Item(arr(i, 4)) = Array(b, ten, a)
                           Else
                              c = dic.Item(arr(i, 4))(2)
                              arr1(c, 15) = arr1(c, 15) + 1
                           End If
                      End If
                   End If
                Next i
           End If
       End If
  Next
  With Sheets("Tonghop")
       .Cells.ClearContents
       If a Then .Range("A1").Resize(a, 15).Value = arr1
  End With
End Sub

Chuẩn xác, giờ mình ngồi nghiên cứu Code đây. Cảm ơn bạn nhiều nhé!
Sẵn tiện cho hỏi bạn có dạy VBA online hok, mình nhờ dạy, hihi.

[Giúp đỡ VBA] Lọc ra khách hàng trùng nhau tối thiểu trong 2 sheet

thanhphuongvip

Mới học VBA, hỏi ngu anh chị đừng chửi ạ

File đính kèm

snow25

Thành viên gạo cội

File đính kèm

thanhphuongvip

Mới học VBA, hỏi ngu anh chị đừng chửi ạ

snow25

Thành viên gạo cội

thanhphuongvip

Mới học VBA, hỏi ngu anh chị đừng chửi ạ

snow25

Thành viên gạo cội

thanhphuongvip

Mới học VBA, hỏi ngu anh chị đừng chửi ạ

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng