Çözüldü Koşullu Biçimlendirme

[yyhy]

Öncelikle ek dosya ekleyemedim cep telefonundan konuyu açıyorum.
Bir sütunda metin rakam ve karışık yazılar mevcut.
İçerisinde geçen kelimelerden; MÜŞTEKİ, ŞÜPHELİ, TANIK gibi kelimeler bulunuyor. Hücre içerisindeki sadece su kelimeleri vurgu yapmak ayrı yazı rengi ile renklendirmek istiyorum. Sadece bu kelimeler diğer içerisindeki metin ve rakamlar (T.C. Kimlik No, Adres Bilgisi No'su gibi) renklenmesini istemiyorum.
Koşullu biçimlendirme ile mi yapılır bilemedim.
Forumda farklı konuları inceledim tüm hücreyi vurguluyor.

 

[Necdet]

Merhaba,
Sounuzdan anladığım kadarıyla hücre içinde geçen belirli renkleri renklendirmek ya da farklı font ya da her ikisi ile birlikte biçimlendirmek istiyorsunuz.
Hücreniz formül ile gelmiyorsa bu isteğiniz makro ile yapılır.
Örnek dosyanızı yüklediğinde yardımcı olacak arkadaş/lar çıkacaktır.

 

[yyhy]

Sayın @Necdet bey haklısınız konu açtığımda örnek dosya eklerdim bugün cep telefonundan konu açtığım için dosya ekleyememiştim.
Şimdi bir örnek dosya ekliyorum. Teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Bahsettiğiniz işlem için koşullu biçimlendirme menüsü henüz bu yeteneğe sahip değil.

Aşağıdaki linkte daha önce paylaştığım #18 nolu mesajdaki kodu kendi dosyanıza uyarlaryıp kullanabilirsiniz.

B sütunundakileri A sütununda bulma

Merhabalar. Ek teki dosyada B stunudaki kelimeleri A stunudaki hücreler içinde tespit etmek ve tespit edilen kelimenin renginin değişmesini istiyorum. Koşullu biçimlendirmeden formül yazılarak olursa sevinirim.

www.excel.web.tr

 

[Necdet]

Merhaba,

Korhan bey ilgili linki vermiş, ben de bir şeyler yazmıştım paylaşayım.

Örnek olması açısından bir kod yazdım. Siz sözcüğe göre değişik renklendirme yapabilirsinizb.
M sütununa (2. satırdan başlayarak) aramasını istediğiniz sözcükleri Büyük Harfle yazınız, farklı sütunda yazarsanız ya da aranan sözcükler belirli ve bir kaç tane ise diziye de alabilirsiniz.

Public Sub Formatla()

    Dim rng As Range
    Dim cel As Range
    Dim hcr As Range
    Dim klm As Variant
    Dim i As Integer
    
    Set klm = Range("M2:M" & Range("M1").End(xlDown).Row)
    
    Set rng = Application.InputBox("Renklendirilecek Hücreleri Seçiniz", "Hücre Seçimi", "A1", Type:=8)
    
    With rng.Font
        .Bold = False
        .Color = vbBlack
    End With
    
    For Each cel In rng
    
        If Not cel = "" Then
            For Each hcr In klm
                i = InStr(1, UCase(Replace(Replace(cel, "i", "İ"), "ı", "I")), hcr, vbTextCompare)
                If i > 0 Then
                    With cel.Characters(i, Len(hcr)).Font
                        .Color = hcr.Font.Color
                        .Bold = hcr.Font.Bold
                    End With
                End If
            Next hcr
        End If
        
    Next cel
    
End Sub

 

[yyhy]

Sayın @Necdet bey makroyu uyguladım ama M sütununa yazdığım şekilde oradaki kelimeler gibi renkli olabilir mi?

 

[Necdet]

Merhaba,
5 nolu mesajdaki kodları yeniledim ve son gönderdiğiniz dosyayı ekledim.
Kodları Sayfaya değil Modul içinde olmalı.

 

[yyhy]

Sayın @Necdet bey teşekkürler inceleyip dönüş yaparım.

 

[yyhy]

Sayın @Necdet bey makroyu çalıştırdığım zaman işlem çok uzun sürüyor. Sorunu çözemedim. Acaba sütunu işaretliyorum ondan olabilir mi?

 

[Necdet]

Sadece verileri seçin, tüm sütunu seçerseniz yaklaşık 1,5 milyon satırda işlem yaptırmış olursunuz. ilk dosyanızda veriler düzenli olmadığı için mecburen hücreleri seçtirme yoluna gittim.

Aşağıdaki verdiğim kod ise mantığı biraz daha farklı, B sütununda arama yapar, siz kendinize göre sütun indisini değiştirirsiniz.
Yine aranan sözcükler M2 hücresinden başlayarak ve büyük harfle yazınız

Sub Formatla2()

Dim c As Range, _
    adr As String, _
    i As Integer, _
    j As Integer

    With Range("B:B").Font
        .Bold = False
        .Color = vbBlack
    End With

For i = 2 To Cells(Rows.Count, "M").End(3).Row

    With Range("B:B")
        Set c = .Find(Cells(i, "M"), LookIn:=xlValues)
        If Not c Is Nothing Then
            adr = c.Address
            Do
                j = InStr(1, Evaluate("=UPPER(" & """" & c.Value & """" & ")"), Cells(i, "M"), vbTextCompare)
                If j > 0 Then
                    With c.Characters(j, Len(Cells(i, "M"))).Font
                        .Color = Cells(i, "M").Font.Color
                        .Bold = Cells(i, "M").Font.Bold
'                        .Size = Cells(i, "M").Font.Size
                    End With
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> adr
        End If
    End With
    
Next i

End Sub

/CODE]

 

[Korhan Ayhan]

#4 nolu mesajımda önerdiğim kodu örnek dosyanıza göre uyarladım. Deneyiniz.

 

[yyhy]

Sayın @Necdet bey ve Sayın @Korhan Ayhan bey ihtiyaca cevap verdi çok teşekkür ederim.