Dựa vào VBA xác định các số trùng lặp trong bảng (1 người xem)

[1986QV]

Bài toán của mình có 2 phần. phần 1 tìm theo chiều thuận, phần 2 tìm theo thuận đảo của số. Tất cả đều sử dụng VBA tìm, nhầm tránh nhầm lẫn các số tìm được phải tô màu cụ thể. Rất mong các bạn giúp đỡ mình để mình làm công việc hiệu quả hơn.
Cảm ơn các bạn quan tâm giúp đỡ!

 

[1986QV]

Cảm ơn bác. Code mà bác gửi rất ok.

 

[Quang_Hải]

Cảm ơn bác. Code mà bác gửi rất ok.

Có khoảng gần 10 thành viên tham gia bài này, không biết là đề cập "bác" nào nữa

 

[1986QV]

Bác cũng có công cả, quan trọng là các đều giải quyết được các bài toán và chỉ cho a/e diễn đàn được học hỏi kinh nghiệm.
Cảm ơn mọi người!

 

[sealand]

Tôi thấy cách các bạn dùng e không hợp lý vì mức độ khả thi quá thấp:

-Với số lớn hay số âm e là việc tô màu sẽ lỗi.
-Số cặp màu trùng lớn hơn giới hạn màu thì sao.

Mình tham gia là dùng code sau và khi chuyển đến ô nào thì sẽ tô màu các ô trùng với ô đó thôi.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cl As Range, Luu As String
 If Intersect(Target, UsedRange) Is Nothing Then Exit Sub
  UsedRange.Interior.ColorIndex = 0
   With UsedRange
     Set Cl = .Find(Target.Value, , xlValues)
       If Not Cl Is Nothing Then
        Luu = Cl.Address
           Do
            Cl.Interior.ColorIndex = 7
          Set Cl = .FindNext(Cl)
        Loop While Not Cl Is Nothing And Cl.Address <> Luu
      End If
   End With
End Sub

 

[1986QV]

bạn kiểm tra lại dùm code đâu chạy được.
Thanks!

 

[1986QV]

Rất cảm ơn a/e 4rum chỉ dẫn!

 

[1986QV]

Em nghĩ 1 vòng lập cũng có thể được đấy
Đại khái chắc thế này:

Sub Thuan()
  Dim Rng As Range, Clls As Range, Dic As Object, OldRng As String
  Dim n As Long, tmp As String
  'On Error Resume Next
  Set Rng = Range("A1").CurrentRegion
  Rng.Interior.ColorIndex = xlNone
  Set Dic = CreateObject("Scripting.Dictionary")
  n = 2
  For Each Clls In Rng
    If Clls.Text <> "" Then
      If Not Dic.Exists(Clls.Text) Then
        Dic.Add Clls.Text, Clls.Address
      Else
        If Range(Dic.Item(Clls.Text)).Interior.ColorIndex = xlNone Then
          n = n + 1
          Range(Dic.Item(Clls.Text)).Interior.ColorIndex = n
        End If
        OldRng = Dic.Item(Clls.Text)
        tmp = Dic.Item(Clls.Text) & ", " & Clls.Address
        Dic.Item(Clls.Text) = tmp
        Range(tmp).Interior.ColorIndex = Range(OldRng).Interior.ColorIndex
      End If
    End If
  Next
End Sub

Chỉ có 1 nguy hiểm: n vượt quá 56 thì... Ẹc... Ẹc...

Mình muốn hỏi các bạn chút nếu xác định được 2 số trùng lặp đó và thêm điều kiện có số lần trùng lặp =>3 sẽ được đánh màu sẽ loại bớt cho số lặp lại 2 lần. Mong các bạn sửa lại code trên dùm mình.
Cảm ơn các bạn giúp đỡ!

 

[1986QV]

A/E ra tay giúp mình với!!