• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Aynı Kelimeler Renklensin?

A

aliahmet

Katılım
9 Nisan 2007
Mesajlar
95
Excel Vers. ve Dili
Exel 2003 Türkçe
Merhaba,

A1 hücremde "Ali gel" yazıyor,
B1 hücremde "Mehmet gel" yazıyor.

Ben şöyle bir şey yapmak istiyorum koşullu biçimlendirme yaparak A ile B hücrelerindeki aynı kelime ve kelimeler kırmızı olsun....Karşılaştırma yaparken Büyük küçük harf sıkıntısıda olmasın.

Yardımıcı arkadaşlara teşekkürler...
Örnek ektedir...
 

Ekli dosyalar

Selamlar,

İstediğiniz işlem için kelimeleri tek tek eşleştirmek gerekir. Bunun içinde makro kullanmanız gerekir.

Aşağıdaki kodu boş bir modüle uygulayıp denermisiniz.

Kod: 
Option Explicit
 
Sub AYNI_KELİMELERİ_RENKLENDİR()
    Dim X1 As Long, X2 As Integer, AYIR_A() As String, BUL_A As Integer, BUL_B As Integer
        
    Application.ScreenUpdating = False
    
    Range("A:B").Font.ColorIndex = 0
        
    For X1 = 2 To Cells(Rows.Count, 1).End(3).Row
        AYIR_A = Split(Cells(X1, 1), " ")
        For X2 = 0 To UBound(AYIR_A)
            If AYIR_A(X2) <> "" Then
                
                BUL_B = InStr(1, BÜYÜKHARF(Cells(X1, 2)), BÜYÜKHARF(AYIR_A(X2)), vbTextCompare)
                If BUL_B > 0 Then
                    With Cells(X1, 2).Characters(Start:=BUL_B, Length:=Len(AYIR_A(X2))).Font
                        .ColorIndex = 3
                    End With
                End If
                
                BUL_A = InStr(1, BÜYÜKHARF(Cells(X1, 1)), BÜYÜKHARF(AYIR_A(X2)), vbTextCompare)
                If BUL_B > 0 And BUL_A > 0 Then
                    With Cells(X1, 1).Characters(Start:=BUL_A, Length:=Len(AYIR_A(X2))).Font
                        .ColorIndex = 3
                    End With
                End If
                
            
            End If
        Next
    Next
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Function BÜYÜKHARF(VERİ As String)
    On Error Resume Next
    BÜYÜKHARF = UCase(Replace(Replace(VERİ, "ı", "I"), "i", "İ"))
End Function
 
Alternatif;
Kod: 
Sub BulBoya()
Columns("a:b").Font.Color = xlblack
For i = 2 To [a65536].End(3).Row
    a = Len(Trim(Cells(i, 1)))
    b = Len(WorksheetFunction.Substitute(Cells(i, 1), " ", ""))
    c = a - b
    For j = 0 To c
        d = Split(Cells(i, 1), " ")(j)
        For t = 2 To [b65536].End(3).Row
            Set Z = Columns(2).Find("*" & d & "*")

            If Not Z Is Nothing Then
                x = WorksheetFunction.Search(d, Cells(i, 1))
                y = WorksheetFunction.Search(d, Cells(Z.Row, 2))
                Cells(i, 1).Characters(x, Len(d)).Font.Color = vbRed
                Cells(Z.Row, 2).Characters(y, Len(d)).Font.Color = vbRed
            End If
        Next t
    Next j
Next i
End Sub
 
Merhaba,

Korhan hocam makroyu denedim şöyle bir sorun çıktı küçük, büyük harfte makro çalışmıyor.

Hamitcan hocam sizin yazdığınız makro da bütün bir sayfadaki kelimelerin aynısını bulup renklendiriyor. Ben istiyorum ki sadece aynı satırda örneğin A1, B1 satırlarında karşılaştırma yapsın.

Zaman ayırdığınız için çok teşekkür ederim.
 
Selamlar,

Ben önerdiğim kodu denedim. Büyük-küçük harfli verilerde de çalıştı. Sizin istediğiniz çözüm farklı ise lütfen örnek dosyanız üzerinde detaylı açıklama yapınız.


aliahmet' Alıntı:
Merhaba,

Korhan hocam makroyu denedim şöyle bir sorun çıktı küçük, büyük harfte makro çalışmıyor.
....
Zaman ayırdığınız için çok teşekkür ederim.
Genişletmek için tıkla ...
 
Hocam örnek ektedir. Sanırım İ, i harfi ile ilgili bir sorun var ?
 

Ekli dosyalar

Selamlar,

Haklısınız "i" harfinden dolayı sorun oluşmuş. Üstteki mesajımdaki koda gerekli eklemeleri yaptım. İncelermisiniz.
 
Korhan Ayhan' Alıntı:
Selamlar,

Haklısınız "i" harfinden dolayı sorun oluşmuş. Üstteki mesajımdaki koda gerekli eklemeleri yaptım. İncelermisiniz.
Genişletmek için tıkla ...


Son bir sorum olacak... Karşılaştırılacak hücreleri nasıl değiştirebilirim. Örneğin "C" hücresi le "S" hücresindeki verileri karşılaştırmak istiyorum. Kodlarda hangi alanları değiştirmem gerekiyor. Teşekkürler...


Çok teşekkür ederim....
 
Son düzenleme:
hamitcan' Alıntı:
Alternatif;
Kod: 
Sub BulBoya()
Columns("a:b").Font.Color = xlblack
For i = 2 To [a65536].End(3).Row
    a = Len(Trim(Cells(i, 1)))
    b = Len(WorksheetFunction.Substitute(Cells(i, 1), " ", ""))
    c = a - b
    For j = 0 To c
        [COLOR="Red"]d = Split(Cells(i, 1), " ")(j)[/COLOR]        
For t = 2 To [b65536].End(3).Row
            Set Z = Columns(2).Find("*" & d & "*")

            If Not Z Is Nothing Then
                x = WorksheetFunction.Search(d, Cells(i, 1))
                y = WorksheetFunction.Search(d, Cells(Z.Row, 2))
                Cells(i, 1).Characters(x, Len(d)).Font.Color = vbRed
                Cells(Z.Row, 2).Characters(y, Len(d)).Font.Color = vbRed
            End If
        Next t
    Next j
Next i
End Sub
Genişletmek için tıkla ...

Hocam bu kod çalışıyor ve ardından kırmızı olan yer hata veriyor.

Hata : Subscript out of range
Sebebini çözemedim yarımcı olabilirmisiniz. Teşekkürler...
 
Son düzenleme:
Selamlar,

Aşağıdak kodu denermisiniz.

aliahmet' Alıntı:
Son bir sorum olacak... Karşılaştırılacak hücreleri nasıl değiştirebilirim. Örneğin "C" hücresi le "S" hücresindeki verileri karşılaştırmak istiyorum. Kodlarda hangi alanları değiştirmem gerekiyor. Teşekkürler...


Çok teşekkür ederim....
Genişletmek için tıkla ...


Kod: 
Option Explicit
 
Sub AYNI_KELİMELERİ_RENKLENDİR()
    Dim X1 As Long, X2 As Integer, AYIR_A() As String, BUL_A As Integer, BUL_B As Integer
        
    Application.ScreenUpdating = False
    
    Range("C:C,S:S").Font.ColorIndex = 0
        
    For X1 = 2 To Cells(Rows.Count, 3).End(3).Row
        AYIR_A = Split(Cells(X1, 3), " ")
        For X2 = 0 To UBound(AYIR_A)
            If AYIR_A(X2) <> "" Then
                
                BUL_B = InStr(1, BÜYÜKHARF(Cells(X1, 19)), BÜYÜKHARF(AYIR_A(X2)), vbTextCompare)
                If BUL_B > 0 Then
                    With Cells(X1, 19).Characters(Start:=BUL_B, Length:=Len(AYIR_A(X2))).Font
                        .ColorIndex = 3
                    End With
                End If
                
                BUL_A = InStr(1, BÜYÜKHARF(Cells(X1, 3)), BÜYÜKHARF(AYIR_A(X2)), vbTextCompare)
                If BUL_B > 0 And BUL_A > 0 Then
                    With Cells(X1, 3).Characters(Start:=BUL_A, Length:=Len(AYIR_A(X2))).Font
                        .ColorIndex = 3
                    End With
                End If
                
            
            End If
        Next
    Next
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Function BÜYÜKHARF(VERİ As String)
    On Error Resume Next
    BÜYÜKHARF = UCase(Replace(Replace(VERİ, "ı", "I"), "i", "İ"))
End Function
 
Hocam merhaba,

Bir şeyi merak ediyorum sizin kodları incelediğimde karşılaştırılacak hücreleri
"Range("C:C,S:S").Font.ColorIndex = 0" kodlarıyla mı belirliyorsunuz. Benim örneğin yeni bir excel tablom var "Range("C:C,E:E").Font.ColorIndex = 0" C Sütunu ile E sütununu karşılaştırmak istediğimde "İşleminiz tamamlanmıştır" uyarısı geliyor fakat kelimeler renklenmiyor. İlginiz için şimdiden teşekürler....
 
Selamlar,

Hayır. O belirttiğiniz bölüm o sütunlardaki renkleri sıfırlamak için kullanılmıştır. Asıl karşılaştırma işlemi FOR ile başlayan döngü bölümünde yapılmaktadır.

E sütunu için kod içinde geçen ",19" değerlerini ",5" olarak değiştirmeniz yeterli olacaktır.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst