HightLight duplicates ở nhiều sheet (2 người xem)

[madao2]

Chào cả nhà! Em có một file excel tổng hợp từng ngày, mỗi sheet gồm 2 cột CODE và NAME.

Em muốn tô màu những hàng mà chứa CODE giống nhau ở tất cả các sheet. Nếu copy về cùng 1 sheet thì đơn giản nhưng vấn đề là em không được thay đổi dữ liệu trong từng sheet và số lượng sheet tăng lên liên tục có lúc lên đến 40 sheet (em chỉ gởi file đã đơn giản hóa) và em cần đánh dấu lại để kiểm soát những CODE trùng. Nếu làm bằng tay thì rất mất thời gian số lượng dữ liệu này nên em nghĩ dùng VBA là hợp lý nhất nhưng loay hoay hoài chưa tạo được mã ưng ý. VD như code ở dưới thì tô màu được các dữ liệu trùng, nhưng nếu phát sinh thêm sheet thì không tự cập nhật được, đồng thời phải thêm tên sheet mới vào mục Const shtNames As String

Sub HighlightDuplicates()    
    Const shtNames As String = "23,24,25,26"
    Const DupCells As String = "a2:a500"
    
    Dim ws() As String: ws = Split(shtNames, ",")
    Dim i As Integer, j As Integer
    Dim CheckCell As Range, rngFound As Range
    For i = 0 To UBound(ws)
        Sheets(ws(i)).Range(DupCells).Interior.ColorIndex = 0
    Next i
    For i = 0 To UBound(ws)
        For Each CheckCell In Sheets(ws(i)).Range(DupCells)
            If CheckCell.Interior.ColorIndex <> 3 Then
                For j = 0 To UBound(ws)
                    For Each rngFound In Sheets(ws(j)).Range(DupCells)
                        If j = i Then
                            If CheckCell.Address <> rngFound.Address _
                            And LCase(Trim(rngFound.Value)) = LCase(Trim(CheckCell.Value)) Then
                                CheckCell.Interior.ColorIndex = 3
                                rngFound.Interior.ColorIndex = 3
                            End If
                        ElseIf LCase(Trim(rngFound.Value)) = LCase(Trim(CheckCell.Value)) Then
                            CheckCell.Interior.ColorIndex = 3
                            rngFound.Interior.ColorIndex = 3
                        End If
                    Next rngFound
                Next j
            End If
        Next CheckCell
    Next i
    
End Sub

. Mong anh em hỗ trợ giúp em bài này!

 

[madao2]

3 ngày trôi qua mà chưa có cao thủ nào giúp em cả? Các bác có gợi ý gì không nhỉ?

 

[Quang_Hải]

3 ngày trôi qua mà chưa có cao thủ nào giúp em cả? Các bác có gợi ý gì không nhỉ?

Thay code này vào chạy thử. Nếu nói về tốc độ thì bạn sẽ phải ngẩn ngơ khi so với code bạn đang xài.

Sub GetData()
Dim Dic As Object
Dim sh As Worksheet, Tem(), i As Long
Set Dic = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   With sh.Range("A2", sh.[A65536].End(3))
      .Interior.ColorIndex = xlNone
      Tem = .Value
   End With
   For i = 1 To UBound(Tem)
      Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
   Next
Next
For Each sh In Worksheets
   Tem = sh.Range("A2", sh.[A65536].End(3)).Value
   For i = 1 To UBound(Tem)
      If Dic.Item(Tem(i, 1)) > 1 Then
         sh.Cells(i + 1, 1).Interior.ColorIndex = 3
      End If
   Next
Next
End Sub

 

[Quang_Hải]

Anh Hải cho em hỏi là code của anh chỉ áp dụng cho Vùng cố định chiếu từ Cell A2 trở đi. Nếu muốn tùy biến code theo vùng động (không cố định là cột A) thì phải viết code lại như nào ạ? (có nghĩa là giữa các sheet, dữ liệu mã code trùng cần kiểm tra không cố dịnh nằm tại một cột A, mà có thể sheet 1 nằm cột A, nhưng qua sheet 2 thì nó lại nằm cột B).

Xin cảm ơn anh!

1. Ai làm việc với dữ liệu thì phải luôn bố trí sao cho dữ liệu có tính đồng nhất về form mẫu
2. Nếu không thể bố trí đồng nhất thì phải dựa vào dòng tiêu đề mà xác định cột cần so sánh. Nói chung là tùy cơ ứng biến.

 

[madao2]

Thay code này vào chạy thử. Nếu nói về tốc độ thì bạn sẽ phải ngẩn ngơ khi so với code bạn đang xài.

Sub GetData()
Dim Dic As Object
Dim sh As Worksheet, Tem(), i As Long
Set Dic = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   With sh.Range("A2", sh.[A65536].End(3))
      .Interior.ColorIndex = xlNone
      Tem = .Value
   End With
   For i = 1 To UBound(Tem)
      Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
   Next
Next
For Each sh In Worksheets
   Tem = sh.Range("A2", sh.[A65536].End(3)).Value
   For i = 1 To UBound(Tem)
      If Dic.Item(Tem(i, 1)) > 1 Then
         sh.Cells(i + 1, 1).Interior.ColorIndex = 3
      End If
   Next
Next
End Sub

Quá nhanh quá nguy hiểm, em bái phục bác cả hai tay. Cảm ơn bác đã hỗ trợ!!! Chúc bác nhiều sức khỏe nhé!

 

[madao2]

Thay code này vào chạy thử. Nếu nói về tốc độ thì bạn sẽ phải ngẩn ngơ khi so với code bạn đang xài.

Sub GetData()
Dim Dic As Object
Dim sh As Worksheet, Tem(), i As Long
Set Dic = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   With sh.Range("A2", sh.[A65536].End(3))
      .Interior.ColorIndex = xlNone
      Tem = .Value
   End With
   For i = 1 To UBound(Tem)
      Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
   Next
Next
For Each sh In Worksheets
   Tem = sh.Range("A2", sh.[A65536].End(3)).Value
   For i = 1 To UBound(Tem)
      If Dic.Item(Tem(i, 1)) > 1 Then
         sh.Cells(i + 1, 1).Interior.ColorIndex = 3
      End If
   Next
Next
End Sub

Cho em hỏi tham thêm tí. Trong trường hợp muốn loại trừ một giá trị 123456 ở cột A lặp lại nhiều lần nhưng không cần hightlight thì thêm vào code như thế nào bác Hải?

 

[madao2]

Thay code này vào chạy thử. Nếu nói về tốc độ thì bạn sẽ phải ngẩn ngơ khi so với code bạn đang xài.

Sub GetData()
Dim Dic As Object
Dim sh As Worksheet, Tem(), i As Long
Set Dic = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   With sh.Range("A2", sh.[A65536].End(3))
      .Interior.ColorIndex = xlNone
      Tem = .Value
   End With
   For i = 1 To UBound(Tem)
      Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
   Next
Next
For Each sh In Worksheets
   Tem = sh.Range("A2", sh.[A65536].End(3)).Value
   For i = 1 To UBound(Tem)
      If Dic.Item(Tem(i, 1)) > 1 Then
         sh.Cells(i + 1, 1).Interior.ColorIndex = 3
      End If
   Next
Next
End Sub

Em muốn thêm loại trừ để loại bỏ tìm với những ô trống xen lẫn hoặc những ô không cần tô màu thì dùng Dic.remove “” được không bác Hải?

 

[Quang_Hải]

Em muốn thêm loại trừ để loại bỏ tìm với những ô trống xen lẫn hoặc những ô không cần tô màu thì dùng Dic.remove “” được không bác Hải?

Muốn không tô màu những ô trống thì

Sub GetData()
Dim Dic As Object
Dim sh As Worksheet, Tem(), i As Long
Set Dic = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   With sh.Range("A2", sh.[A65536].End(3))
      .Interior.ColorIndex = xlNone
      Tem = .Value
   End With
   For i = 1 To UBound(Tem)
      Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
   Next
Next
For Each sh In Worksheets
   Tem = sh.Range("A2", sh.[A65536].End(3)).Value
   For i = 1 To UBound(Tem)
     If Tem(i,1) <> "" Then
        If Dic.Item(Tem(i, 1)) > 1 Then
           sh.Cells(i + 1, 1).Interior.ColorIndex = 3
        End If
     End If
   Next
Next
End Sub

 

[VetMini]

Em muốn thêm loại trừ để loại bỏ tìm với những ô trống xen lẫn hoặc những ô không cần tô màu thì dùng Dic.remove “” được không bác Hải?

Tôi vẫn lấy làm lạ là những cái ý tưởng như thế này đem ra thử có mất tiền đâu mà sao bà con không chịu thử trước khi hỏi? Hình như hỏi dễ quá nên bà con đâm lười.

Nếu chịu khó thử thì đã biết là lúc tô màu sẽ bị lỗi.
dùng Dic("") = 0 thì có thể được.

 

[madao2]

Muốn không tô màu những ô trống thì

Sub GetData()
Dim Dic As Object
Dim sh As Worksheet, Tem(), i As Long
Set Dic = CreateObject("scripting.dictionary")
For Each sh In Worksheets
   With sh.Range("A2", sh.[A65536].End(3))
      .Interior.ColorIndex = xlNone
      Tem = .Value
   End With
   For i = 1 To UBound(Tem)
      Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
   Next
Next
For Each sh In Worksheets
   Tem = sh.Range("A2", sh.[A65536].End(3)).Value
   For i = 1 To UBound(Tem)
     If Tem(i,1) <> "" Then
        If Dic.Item(Tem(i, 1)) > 1 Then
           sh.Cells(i + 1, 1).Interior.ColorIndex = 3
        End If
     End If
   Next
Next
End Sub

Cảm ơn bác đã hỗ trợ ạ!

Tôi vẫn lấy làm lạ là những cái ý tưởng như thế này đem ra thử có mất tiền đâu mà sao bà con không chịu thử trước khi hỏi? Hình như hỏi dễ quá nên bà con đâm lười.

Nếu chịu khó thử thì đã biết là lúc tô màu sẽ bị lỗi.
dùng Dic("") = 0 thì có thể được.

Dạ em có thử rồi nhưng bị lỗi, ý em là có cách nào khác không, và viết thế nào cho đúng ạ, xin lỗi vì đã không nói rõ ràng ạ!

 

[VetMini]

Tôi không có sẵn máy ở đây nên tạm không nói đến ngữ pháp. Chỉ nói về lô gíc code:

Ý của bạn dùng remove "" để loại trị trống ra khỏi Dic, và như vậy sẽ tránh không tô màu ô trống. Giải thuật này sẽ bị vướng mắc khi ở vòng lặp thứ hai, code hỏi Dic để tìm số lặp lại cho trị trống, vì Dic không còn chứa trij trống cho nên sẽ bị lỗi. Cái này nhìn code là thấy liền, khỏi cần thử.

Đương nhiên cách dễ nhất là cách xét trực tiếp trị trống như bài #9 của chính tác giả. Tôi chỉ mách thêm cho bạn một phương pháp khác là đổi số lặp lại của trống là 0. Trong vòng lặp thứ 2, vì Dic cho code biết số lặp lại của trống là 0 (<1) cho nên các ô trống sẽ được bỏ qua.

 

[madao2]

Vậy trong trường hợp dữ liệu ở 2 cell giống nhau nhưng một cell định dạng Text và một cell định dạng number thì cách khắc phục là như thế nào ạ?

 

[Quang_Hải]

Vậy trong trường hợp dữ liệu ở 2 cell giống nhau nhưng một cell định dạng Text và một cell định dạng number thì cách khắc phục là như thế nào ạ?

Sửa lại chút trong code là được.

Tem(i, 1) sẽ sửa lại là Val(Tem(i, 1))

Ví dụ
Dic(Tem(i, 1)) = Dic.Item(Tem(i, 1)) + 1
Sửa lai là
Dic(Val(Tem(i, 1))) = Dic.Item(Val(Tem(i, 1))) + 1

Tìm và sửa hết là được

 

[madao2]

Còn gì mà bác không biết không bác Hải? Em ở Dĩ An, hôm nào anh em mình off nhé!

 

[Quang_Hải]

Còn gì mà bác không biết không bác Hải? Em ở Dĩ An, hôm nào anh em mình off nhé!

Những gì bạn thấy chỉ là cơ bản của VBA thôi. Mà dân nghiệp dư như mình thì cũng chỉ cần cơ bản là đủ cho công việc
........................
Mình ở bên Lái Thiêu. Hôm nào rảnh thì cứ alo uống cafe.

0908 247 563