Aynı tabloda tekrar eden metinleri koşullu biçimlendirme ile renklendirme

[cem116]

İyi akşamlar. Daha önceki konularda yaklaşık 45 dakikalık bir arayıştan sonra tam olarak aradığım cevabı bulamadığım için desteğinize ihtiyacım var. Elimdeki tabloda aynı sözcüklerin tekrar ettiği bir durum söz konusu. Ben tabloda geçen sözcüklerden aynı olanların dolgu renklerinin aynı olmasını istiyorum. Ancak tek bir sözcük değil, birden fazla sözcük var tekrar eden ve hepsini farklı şekilde boyamam gerekiyor. Ama bunu nasıl sağlayacağımı bulamadım. Tek tek dolgu rengi vermek uzun bir işlem, tablom biraz büyük ve uzun. Ama yapmak istediğimi başka bir örnek tablo üzerinden aşağıda yüklediğim dosya ile anlatmaya çalıştım. Destekleriniz için şimdiden çok teşekkürler. Yarına yetiştirmek zorunda olduğum bir iş. Umarım müsait olan üstadlardan hızlı bir dönüş gelir. Herkese iyi akşamlar.

 

[muygun]

Merhaba;
Mokro çözümlü eki deneyin.
iyi çalışmalar.

 

[cem116]

Merhaba, Sayın muygun elinize sağlık. Kesinlikle tam olarak aradığım şey. Ellerinize sağlık. Bu durum sık sık ihtiyaç duyduğum bir durum. Kodları başka dosyalara kendim uygulamak istersem başarabilir miyim acaba ? kodları biraz inceledim. Umarım başarabilirim. Ellerinize sağlık. Hızır gibi yetiştiniz

 

[cem116]

Merhaba, Sayın muygun elinize sağlık. Kesinlikle tam olarak aradığım şey. Ellerinize sağlık. Bu durum sık sık ihtiyaç duyduğum bir durum. Kodları başka dosyalara kendim uygulamak istersem başarabilir miyim acaba ? kodları biraz inceledim. Umarım başarabilirim. Ellerinize sağlık. Hızır gibi yetiştiniz

Sub renklendir()
Application.ScreenUpdating = False
On Error Resume Next
Call renksil
For i = 2 To Range("c65536").End(xlUp).Row
For k = 3 To Cells(1, 256).End(xlToLeft).Column
If Cells(i, 2) <> "ŞUBE" Then
For z = 2 To Range("a65536").End(xlUp).Row
If Cells(i, k) = Cells(z, 1) Then
Cells(i, k).Interior.ColorIndex = Cells(z, 1).Interior.ColorIndex
End If
Next z
End If
Next k
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Sub renksil()
For i = 2 To Range("b65536").End(xlUp).Row
If Cells(i, 2) <> "ŞUBE" Then
Range("c" & i & ":ıv" & i).Interior.ColorIndex = xlNone
End If
Next i
End Sub


Bu kodlarda tablonun yerleri değişirse nereleri değiştirmem gerekir acaba ? Yani aralıkları nasıl belirleyebilirim ?

 

[muygun]

Merhaba;

For i = 2 To Range("c65536").End(xlUp).Row
i döngüsü 2.satırdan başlayıp c sütununda son dolu satıra kadar dönüyor

For k = 3 To Cells(1, 256).End(xlToLeft).Column
k döngüsü 3.sütundan başlayıp 1. satırda son dolu sütuna kadar dönüyor

If Cells(i, 2) <> "ŞUBE" Then
eğer i satır ve 2 sütun değeri "ŞUBE" ye eşit değilse;

For z = 2 To Range("a65536").End(xlUp).Row
z döngüsü 2. satırdan a sütununda son dolu hücreye kadar dönüyor

If Cells(i, k) = Cells(z, 1) Then
eğer i,k adresindeki değer z,1 adresindeki değere eşit ise

Cells(i, k).Interior.ColorIndex = Cells(z, 1).Interior.ColorIndex
i,k adresi zemin rengini z,1 zemin rengine eşitle

İşlemi gerçekleştiren kodların açıklaması bu

Farklı bir mantıkla bir sayfa renk kodlaması için oluşturursanız 2.,3.,4. vs sayfalarda aynı mantığı kurgulayabilirsiniz.

 

[Korhan Ayhan]

Alternatif;

Klasik CTRL+F (Bul) kodları kullanılmıştır.

Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, Aranan As Range
    Dim Tablo As Range, Bul As Range, Adres As String
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa4")
    Set Tablo = S1.Range("A1:I22")
    
    For Each Aranan In Tablo.Columns(1).Cells
        If Aranan.Value <> "ŞUBE" Then
            Aranan.Offset(, 1).Resize(1, Tablo.Columns.Count - 1).Interior.Color = xlNone
        End If
    Next
    
    For Each Aranan In S1.Range("A25:A32")
        Set Bul = Tablo.Find(Aranan.Value, , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                Bul.Interior.Color = Aranan.Interior.Color
                Set Bul = Tablo.FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    Next
    
    Set Tablo = Nothing
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub

 

[cem116]

Merhaba;

For i = 2 To Range("c65536").End(xlUp).Row
i döngüsü 2.satırdan başlayıp c sütununda son dolu satıra kadar dönüyor

For k = 3 To Cells(1, 256).End(xlToLeft).Column
k döngüsü 3.sütundan başlayıp 1. satırda son dolu sütuna kadar dönüyor

If Cells(i, 2) <> "ŞUBE" Then
eğer i satır ve 2 sütun değeri "ŞUBE" ye eşit değilse;

For z = 2 To Range("a65536").End(xlUp).Row
z döngüsü 2. satırdan a sütununda son dolu hücreye kadar dönüyor

If Cells(i, k) = Cells(z, 1) Then
eğer i,k adresindeki değer z,1 adresindeki değere eşit ise

Cells(i, k).Interior.ColorIndex = Cells(z, 1).Interior.ColorIndex
i,k adresi zemin rengini z,1 zemin rengine eşitle

İşlemi gerçekleştiren kodların açıklaması bu

Farklı bir mantıkla bir sayfa renk kodlaması için oluşturursanız 2.,3.,4. vs sayfalarda aynı mantığı kurgulayabilirsiniz.

Çok teşekkürler, biraz yoğun bir dönemden geçiyoruz da şimdi siteye girebildim yeni görüyorum mesajlarınızı kusura bakmayın.

 

[cem116]

Alternatif;

Klasik CTRL+F (Bul) kodları kullanılmıştır.

Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, Aranan As Range
    Dim Tablo As Range, Bul As Range, Adres As String
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Sayfa4")
    Set Tablo = S1.Range("A1:I22")
   
    For Each Aranan In Tablo.Columns(1).Cells
        If Aranan.Value <> "ŞUBE" Then
            Aranan.Offset(, 1).Resize(1, Tablo.Columns.Count - 1).Interior.Color = xlNone
        End If
    Next
   
    For Each Aranan In S1.Range("A25:A32")
        Set Bul = Tablo.Find(Aranan.Value, , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                Bul.Interior.Color = Aranan.Interior.Color
                Set Bul = Tablo.FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    Next
   
    Set Tablo = Nothing
    Set S1 = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub

Çok teşekkürler, sisteme girmiyordum bir süredir daha doğrusu giremiyordum yoğunluktan. Şimdi girince gördüm mesajlarınızı, çok teşekkür ederim.