Cách tô màu giá trị trùng nhau .

[vovanthanh2602]

Mọi người giúp em với , mong muốn như hình và file đính kèm ạ. em cảm ơn nhiều.

 

[Hoàng Tuấn 868]

Cầu cứu VBA . tô màu giá trị trùng nhau .​

Tiêu đề phạm quy. .

 

[vovanthanh2602]

Tiêu đề phạm quy. .

đã sửa ạ. em cảm ơn

 

[anhtuan2939]

Bạn kiểm tra thử xem

Sub To_mau()
    Dim dic1 As Object, dic2 As Object
    Dim i As Long, lr As Long, Row As Long
    Dim tmp
    
    Application.ScreenUpdating = False
    
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic1.CompareMode = vbTextCompare
    dic2.CompareMode = vbTextCompare
    
    With Sheets("Sheet2")
        .Range("A1:H1000").Interior.ColorIndex = xlNone
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To lr
            tmp = .Range("A" & i).Value & .Range("B" & i).Value
            If tmp <> Empty Then dic1.Add tmp, i
        Next i
        
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        For i = 2 To lr
            tmp = .Range("D" & i).Value & .Range("E" & i).Value
            If dic1.Exists(tmp) Then
                Row = dic1.Item(tmp)
                .Range("A" & Row & ":B" & Row).Interior.ColorIndex = 26
                .Range("D" & i & ":E" & i).Interior.ColorIndex = 26
            End If
            If tmp <> Empty Then dic2.Add tmp, i
        Next i
        
        lr = .Range("G" & Rows.Count).End(xlUp).Row
        For i = 2 To lr
            tmp = .Range("G" & i).Value & .Range("H" & i).Value
            If dic1.Exists(tmp) Then
                Row = dic1.Item(tmp)
                .Range("A" & Row & ":B" & Row).Interior.ColorIndex = 26
                .Range("G" & i & ":H" & i).Interior.ColorIndex = 26
            End If
            If dic2.Exists(tmp) Then
                Row = dic2.Item(tmp)
                .Range("D" & Row & ":E" & Row).Interior.ColorIndex = 26
                .Range("G" & i & ":H" & i).Interior.ColorIndex = 26
            End If
        Next i
    End With
    
    
    Set dic1 = Nothing
    Set dic2 = Nothing
    Application.ScreenUpdating = True
End Sub

 

[Phuocam]

Mọi người giúp em với , mong muốn như hình và file đính kèm ạ. em cảm ơn nhiều.
View attachment 280929

Có trường hợp trong 1 cụm, nó trùng nhau không?

.

 

[vovanthanh2602]

Có trường hợp trong 1 cụm, nó trùng nhau không?

Có trường hợp trong 1 cụm, nó trùng nhau không?

.

Không có trường hợp đó ạ.

 

[vovanthanh2602]

Bạn kiểm tra thử xem

Sub To_mau()
    Dim dic1 As Object, dic2 As Object
    Dim i As Long, lr As Long, Row As Long
    Dim tmp
   
    Application.ScreenUpdating = False
   
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic1.CompareMode = vbTextCompare
    dic2.CompareMode = vbTextCompare
   
    With Sheets("Sheet2")
        .Range("A1:H1000").Interior.ColorIndex = xlNone
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To lr
            tmp = .Range("A" & i).Value & .Range("B" & i).Value
            If tmp <> Empty Then dic1.Add tmp, i
        Next i
       
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        For i = 2 To lr
            tmp = .Range("D" & i).Value & .Range("E" & i).Value
            If dic1.Exists(tmp) Then
                Row = dic1.Item(tmp)
                .Range("A" & Row & ":B" & Row).Interior.ColorIndex = 26
                .Range("D" & i & ":E" & i).Interior.ColorIndex = 26
            End If
            If tmp <> Empty Then dic2.Add tmp, i
        Next i
       
        lr = .Range("G" & Rows.Count).End(xlUp).Row
        For i = 2 To lr
            tmp = .Range("G" & i).Value & .Range("H" & i).Value
            If dic1.Exists(tmp) Then
                Row = dic1.Item(tmp)
                .Range("A" & Row & ":B" & Row).Interior.ColorIndex = 26
                .Range("G" & i & ":H" & i).Interior.ColorIndex = 26
            End If
            If dic2.Exists(tmp) Then
                Row = dic2.Item(tmp)
                .Range("D" & Row & ":E" & Row).Interior.ColorIndex = 26
                .Range("G" & i & ":H" & i).Interior.ColorIndex = 26
            End If
        Next i
    End With
   
   
    Set dic1 = Nothing
    Set dic2 = Nothing
    Application.ScreenUpdating = True
End Sub

Chào bạn.
Nếu bây giờ mình tăng lên 1 cụm thành 4 giá trị thì làm sao nhỉ? bạn giúp mình với nhé. cảm ơn nhiều ạ.

 

[vovanthanh2602]

Chào bạn.
Nếu bây giờ mình tăng lên 1 cụm thành 4 giá trị thì làm sao nhỉ? bạn giúp mình với nhé. cảm ơn nhiều ạ.

View attachment 280961

À. MÌNH LAM ĐƯỢC RỒI Ạ. CẢM ƠN NHIỀU