Eşleşen Verileri Bulma

[trtyt20]

Arkadaşlar istediğim şey küçük bir tarama işlemi aynı iki verinin bulunmasını istiyorum detaylı açıklmayı ekte belirttim şimdiden ilgilenen arkadaşlara teşekkür ederim.
http://dosya.co/zx58cg5e7mt2/YARDIM.xlsx.html

 

[Ziynettin]

Kodu deneyin.

Sub renklendir()
    Dim a As Range, b As Range, c As Range
    Dim d As Object
    Set a = Range("B1:B" & [B65000].End(xlUp).Row)
    Set b = Range("L1:L" & [L65000].End(xlUp).Row)
    Union(a, b).Interior.ColorIndex = xlNone
    Set d = CreateObject("Scripting.Dictionary")
    renk = Array(1, 3, 4, 5, 6, 7, 8, 9, 10) ' 56 kadar tamam layabilirsiniz.
        For Each c In a
            d(c.Value) = d(c.Value) & c.Row & "-"
        Next c
        For Each c In b
            If d.exists(c.Value) Then
                no = Application.Match(c.Value, d.keys, 0) Mod UBound(renk)
                c.Interior.ColorIndex = renk(no)
                deg = Split(d(c.Value), "-")
                For j = LBound(deg) To UBound(deg) - 1
                    i = deg(j) - a.Row + 1
                    a(i).Interior.ColorIndex = renk(no)
                Next j
            End If
        Next c
    MsgBox "Renk işlemi tamam.", vbInformation, "excel.web.tr"
End Sub

 

[trtyt20]

Teşekkür ederim elimde bir dosya daha var acaba bunuda yapabilir miyiz buna benzer gerekli açıklamayı ekteki linkte belirttim.
http://dosya.co/cg3iesxlnky7/YARDIM.xlsx.html

 

[Ziynettin]

Tüm gruplar 5 sütun ara ile BO sütunu 4 sütun sonra yazılmış. BO sütununu BP sütununa taşıyıp kodu öyle deneyiniz.

Sub grup_renklendir()
    Cells.Interior.ColorIndex = xlNone
    renk = Array(1, 3, 4, 6, 7, 8, 9, 10) ' isteğe bağlı 56'ye kadar çoğaltabilirsiniz.
    Set d = CreateObject("Scripting.Dictionary")
    For j = 2 To 68 Step 6
        son = Cells(Rows.Count, j).End(3).Row
        For Each c In Cells(1, j).Resize(son)
            If c <> "" Then
                d.Item(c.Value) = d.Item(c.Value) + 1
            End If
        Next c
        For Each c In Cells(1, j).Resize(son)
            If c <> "" Then
                n = Application.Match(c.Value, d.keys, 0) Mod UBound(renk)
                If d.Item(c.Value) > 0 Then
                    c.Interior.ColorIndex = renk(n)
                End If
            End If
        Next c
    Next j
    MsgBox "İşlem Bitti.", vbInformation, "excel.web.tr"
End Sub