Cümlelerdeki kelimelerde mükerrer bulma

[yanginci34]

Arkadaşlar merhaba; Mükerrerleri bulma konusu ama biraz farklı şöyle örnek vereyim.
A sütununda
A1 Erhan KESKİN - Ahmet AHMETOĞLU
A2 Mehmet MEHMETOĞLU - Erhan KESKİN
buna göre sadece Erhan KESKİN isimleri kırmızı renkte olması lazım.

 

[Necdet]

Erhan KESKİN - Ahmet AHMETOĞLU
Mehmet MEHMETOĞLU - Erhan KESKİN

istediğiniz biçim yukarıdaki gibi mi olacak?

 

[yanginci34]

Erhan KESKİN - Ahmet AHMETOĞLU
Mehmet MEHMETOĞLU - Erhan KESKİN

istediğiniz biçim yukarıdaki gibi mi olacak?

Evet Hocam aynen öyle

 

[AdemCan]

Merhaba örnek olarak kullanılabilir.

Değiştirilmesi gereken alanlar
Set s1 = Sheets("Sayfa1") satırındaki Sayfa1 ismini, dosyanızdaki çalışma sayfasının adı ile değiştiriniz.

Sub kontrol()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, i As Long, bul As Byte, uzunluk As Byte, aranan As String
Set s1 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 1).End(3).Row
aranan = "Erhan KESKİN"
uzunluk = Len(aranan)

With s1.Range("A1:A" & son).Font
    .ColorIndex = xlAutomatic
    .Bold = False
End With

For i = 1 To son
    If s1.Cells(i, "A") Like "*" & aranan & "*" Then
        bul = WorksheetFunction.Search(aranan, s1.Cells(i, "A"))
            With s1.Cells(i, "A").Characters(Start:=bul, Length:=uzunluk).Font
                .FontStyle = "Kalın"
                .Color = vbRed
            End With
    End If
Next i

Set s1 = Nothing: son = 0: i = 0: bul = 0
uzunluk = 0: aranan = ""
Application.ScreenUpdating = True
End Sub

 

[yanginci34]

Merhaba örnek olarak kullanılabilir.

Değiştirilmesi gereken alanlar
Set s1 = Sheets("Sayfa1") satırındaki Sayfa1 ismini, dosyanızdaki çalışma sayfasının adı ile değiştiriniz.

Sub kontrol()
Application.ScreenUpdating = False
Dim s1 As Worksheet, son As Long, i As Long, bul As Byte, uzunluk As Byte, aranan As String
Set s1 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 1).End(3).Row
aranan = "Erhan KESKİN"
uzunluk = Len(aranan)

With s1.Range("A1:A" & son).Font
    .ColorIndex = xlAutomatic
    .Bold = False
End With

For i = 1 To son
    If s1.Cells(i, "A") Like "*" & aranan & "*" Then
        bul = WorksheetFunction.Search(aranan, s1.Cells(i, "A"))
            With s1.Cells(i, "A").Characters(Start:=bul, Length:=uzunluk).Font
                .FontStyle = "Kalın"
                .Color = vbRed
            End With
    End If
Next i

Set s1 = Nothing: son = 0: i = 0: bul = 0
uzunluk = 0: aranan = ""
Application.ScreenUpdating = True
End Sub

Hocam öncelikle ilginiz için çok teşekkür ederim lakin ben sadece tek isim aramıyorum onu örnek verdim olaki Ahmet AHMETOĞLU da başka bir hücrede geçerse o ismi de kırmızı yapsın. Yani belli bir isim değil tüm isimlerin mükerrer olanları kırmızı olması gerekmekte.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub Renklendir()

    Dim i   As Long, _
        j   As Integer, _
        k   As Integer, _
        c   As Range, _
        adr As String, _
        sd  As Object, _
        dk  As Variant, _
        key As Variant, _
        itm As Variant, _
        s   As Variant

    Set sd = CreateObject("Scripting.Dictionary")
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        s = Split(Trim(Cells(i, "A")), " - ")
        For j = 0 To UBound(s)
            If Not sd.exists(s(j)) Then
                sd.Add s(j), 1
            Else
                sd.Item(s(j)) = sd.Item(s(j)) + 1
            End If
        Next j
    Next i
        
    key = sd.keys 'Anahtar Değerleri Atanır
    itm = sd.items
    
    For i = 0 To UBound(key)
        If itm(i) > 1 Then
            With Range("A:A")
                Set c = .Find(key(i), LookAt:=xlPart)
                If Not c Is Nothing Then
                    adr = c.Address
                    Do
                        k = InStr(c.Value, key(i))
                        c.Characters(k, Len(key(i)) + 0).Font.Color = vbRed
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> adr
                End If
            End With
        End If
    Next i
    
End Sub

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Color_Duplicate_Names()
    Dim My_Array As Object, My_Data As Range, Name_Split As Variant
    Dim Name_List As Variant, Searched_Data As Variant, X As Long
    Dim Locked_Value As Variant, Find_Position As Long, WF As WorksheetFunction
        
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    Set WF = WorksheetFunction
    
    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False
    
    For Each My_Data In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
        Name_Split = VBA.Split(My_Data.Value, "-")
        For X = LBound(Name_Split) To UBound(Name_Split)
            Searched_Data = VBA.UCase(VBA.Replace(VBA.Replace(WF.Trim(Name_Split(X)), "ı", "I"), "i", "İ"))
            My_Array(Searched_Data) = My_Array(Searched_Data) + 1
        Next
    Next

    For Each Name_List In My_Array.Keys
        If My_Array(Name_List) > 1 Then
            For Each My_Data In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
                Locked_Value = VBA.UCase(VBA.Replace(VBA.Replace(My_Data.Value, "ı", "I"), "i", "İ"))
                For X = 1 To Len(Locked_Value)
                    Find_Position = VBA.InStr(X, Locked_Value, Name_List)
                    If Find_Position > 0 Then
                        My_Data.Characters(Find_Position, VBA.Len(Name_List)).Font.Bold = True
                        My_Data.Characters(Find_Position, VBA.Len(Name_List)).Font.Color = -16777024
                    Else
                        Exit For
                    End If
                    X = Find_Position + VBA.Len(Name_List)
                Next
            Next
        End If
    Next

    Set My_Array = Nothing
    Set WF = Nothing

    MsgBox "Your transaction is complete.", vbInformation
End Sub

 

[yanginci34]

Sayın Necdet Hocam ve Sayın Korhan Hocam Ellerinize sağlık.

 

[Korhan Ayhan]

Ben önerdiğim kodda küçük bir revize yaptım. Şimdi daha sağlıklı çalışıyor.

Büyük-küçük harf duyarsız hale getirdim.
Aynı zamanda aynı hücre içinde örnek olarak aşağıdaki gibi bir veri olunca sadece biri renkleniyordu.

AHMET - MEHMET - ahmet

Sanırım kodun son hali bu özellikleri dahil edince daha işlevsel oldu.

 

[yanginci34]

Alternatif;

Option Explicit

Sub Color_Duplicate_Names()
    Dim My_Array As Object, My_Data As Range, Name_Split As Variant
    Dim Name_List As Variant, Searched_Data As Variant, X As Long
    Dim Locked_Value As Variant, Find_Position As Long, WF As WorksheetFunction
       
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    Set WF = WorksheetFunction
   
    Range("A:A").Font.Bold = False
    Range("A:A").Font.Color = False
   
    For Each My_Data In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
        Name_Split = VBA.Split(My_Data.Value, "-")
        For X = LBound(Name_Split) To UBound(Name_Split)
            Searched_Data = VBA.UCase(VBA.Replace(VBA.Replace(WF.Trim(Name_Split(X)), "ı", "I"), "i", "İ"))
            My_Array(Searched_Data) = My_Array(Searched_Data) + 1
        Next
    Next

    For Each Name_List In My_Array.Keys
        If My_Array(Name_List) > 1 Then
            For Each My_Data In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
                Locked_Value = VBA.UCase(VBA.Replace(VBA.Replace(My_Data.Value, "ı", "I"), "i", "İ"))
                For X = 1 To Len(Locked_Value)
                    Find_Position = VBA.InStr(X, Locked_Value, Name_List)
                    If Find_Position > 0 Then
                        My_Data.Characters(Find_Position, VBA.Len(Name_List)).Font.Bold = True
                        My_Data.Characters(Find_Position, VBA.Len(Name_List)).Font.Color = -16777024
                    Else
                        Exit For
                    End If
                    X = Find_Position + VBA.Len(Name_List)
                Next
            Next
        End If
    Next

    Set My_Array = Nothing
    Set WF = Nothing

    MsgBox "Your transaction is complete.", vbInformation
End Sub

Evet hocam böyle daha güzel olmuş elinize sağlık.