Renklendir, Kritere Göre

[1Al2Ver]

Merhaba,

"C4:N35" arası tablom var,

"Q1" deki ifade dışında kalan ;

PT, SL, ÇR, PR, CU, CT ve Pz kısaltmaları için, tabloda renklendirme istiyorum,

Örnek ; "Q1" SL ise ; "SL" dışındaki kısaltmalar (PT, ÇR, PR, CU, CT ve Pz) renklenecek,

Örnek ; "Q1" ÇR ise ; "ÇR" dışındaki kısaltmalar (PT, SL, PR, CU, CT ve Pz) renklenecek,

Örnek ; "Q1" PT ise ; "PT" dışındaki kısaltmalar (SL, ÇR, PR, CU, CT ve Pz), renklenecek.

AÇIKLAMA ; Veriler, tabloya başka bir sayfadan formüllerle alınmaktadır.

Teşekkür ederim.

 

[EmrExcel16]

Merhaba , sayfanın kod bölümüne ekleyerek deneyiniz..

Private Sub Worksheet_Calculate()
    Dim Rng, Veri, AraBul, Bul, FrstAdr, e, m
    Set Rng = Range("C4:N35")
    Veri = Split("PT,SL,ÇR,PR,CU,CT,Pz", ",")
    If Range("Q1") <> "" Then
        Rng.Interior.Pattern = xlNone
        For m = 0 To UBound(Veri)
            If Range("Q1") <> Veri(m) Then
                Set Bul = Rng.Find("*" & Veri(m) & "*", , xlValues, xlWhole)
                If Not Bul Is Nothing Then
                    FrstAdr = Bul.Address
                    Do
                        AraBul = Split(Cells(Bul.Row, Bul.Column), " ")
                        For e = 0 To UBound(AraBul)
                            If AraBul(e) = Veri(m) Then
                                Bul.Interior.Color = vbYellow
                                Exit For
                            End If
                        Next
                        Set Bul = Rng.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> FrstAdr
                End If
            End If
        Next
    End If
End Sub

 

[EmrExcel16]

Dosyada uygulanmış hali.

 

[1Al2Ver]

Sayın EmrExcel16 merhaba,

Çözüm ve ilginiz için teşekkür ederim.

Saygılarımla.

 

[EmrExcel16]

Rica ederim , sağlıklı günler dilerim.

 

[baydeniro]

Dosyada uygulanmış hali.

Teşekkürler üstad

 

[1Al2Ver]

Merhaba,

Çözüme ulaşılan dosyanın kod'una, bir ilave gereksinimi doğdu,

Renklenen hücrelere "Köşegen Yukarı Kenarlık" koymak istiyorum,

Mevcut Kod ; 2 ve 3 nolu mesaj'da ve ek'li dosyada, sayfanın kodunda mevcuttur.

Teşekkür ederim.

 

[YUSUF44]

Aşağıdaki kodu deneyiniz:

Private Sub Worksheet_Calculate()
    Dim Rng, Veri, AraBul, Bul, FrstAdr, e, m
    Set Rng = Range("C4:N35")
    Veri = Split("PT,SL,ÇR,PR,CU,CT,Pz", ",")
    If Range("Q1") <> "" Then
        Rng.Interior.Pattern = xlNone
        For m = 0 To UBound(Veri)
            If Range("Q1") <> Veri(m) Then
                Set Bul = Rng.Find("*" & Veri(m) & "*", , xlValues, xlWhole)
                If Not Bul Is Nothing Then
                    FrstAdr = Bul.Address
                    Do
                        AraBul = Split(Cells(Bul.Row, Bul.Column), " ")
                        For e = 0 To UBound(AraBul)
                            If AraBul(e) = Veri(m) Then
                                With Bul.Borders(xlDiagonalUp)
                                    .LineStyle = xlContinuous
                                    .ColorIndex = xlAutomatic
                                    .TintAndShade = 0
                                    .Weight = xlThin
                                End With
                                Bul.Interior.Color = vbYellow
                                Exit For
                            End If
                        Next
                        Set Bul = Rng.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> FrstAdr
                End If
            End If
        Next
    End If
End Sub

 

[1Al2Ver]

Sayın YUSUF44 merhaba,

İlginiz için teşekkür ederim,

Sanırım bir konuyu atladım, af edersiniz !

Tablo, Veri doğrulama ile değişkenlik gösteriyor,

Bu kod ile, çizgiler tablo değiştikçe, sabit kalıyor,

Kalmaması ve yeni tabloya göre çizgi atılması gerekmektedir.

Bunu aşarsak sorun giderilmiş olacak,

Teşekkür ederim.

 

[YUSUF44]

Aşağıdaki gibi oldu galiba:

Private Sub Worksheet_Calculate()
    Dim Rng, Veri, AraBul, Bul, FrstAdr, e, m
    Set Rng = Range("C4:N35")
    Veri = Split("PT,SL,ÇR,PR,CU,CT,Pz", ",")
    If Range("Q1") <> "" Then
        Rng.Interior.Pattern = xlNone
        Rng.Borders(xlDiagonalUp).LineStyle = xlNone
        For m = 0 To UBound(Veri)
            If Range("Q1") <> Veri(m) Then
                Set Bul = Rng.Find("*" & Veri(m) & "*", , xlValues, xlWhole)
                If Not Bul Is Nothing Then
                    FrstAdr = Bul.Address
                    Do
                        AraBul = Split(Cells(Bul.Row, Bul.Column), " ")
                        For e = 0 To UBound(AraBul)
                            If AraBul(e) = Veri(m) Then
                                With Bul.Borders(xlDiagonalUp)
                                    .LineStyle = xlContinuous
                                    .ColorIndex = xlAutomatic
                                    .TintAndShade = 0
                                    .Weight = xlThin
                                End With
                                Bul.Interior.Color = vbYellow
                                Exit For
                            End If
                        Next
                        Set Bul = Rng.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> FrstAdr
                End If
            End If
        Next
    End If
End Sub

 

[1Al2Ver]

Sayın YUSUF44 tekrar merhaba,

Çok teşekkür ederim, sorun çözülmüştür.

Kandiliniz kutlu olsun,

Saygılarımla.

 

[1Al2Ver]

Merhaba,

Aşağıdaki kodlar, çalışma kitabındaki geri al (Crtl+Z) özelliğini ve "Geri Al-Yinele" fonksiyonlarını etkisiz hale getiriyor, dolayısı ile yapılan bir işlem geri alınamıyor,

Bu sorunu nasıl aşa biliriz ?

Teşekkür ederim.

Private Sub Worksheet_Calculate()
    Dim Rng, Veri, AraBul, Bul, FrstAdr, e, m
    Set Rng = Range("C4:N35")
    Veri = Split("PT,SL,ÇR,PR,CU,CT,Pz", ",")
    If Range("Q1") <> "" Then
        Rng.Interior.Pattern = xlNone
        Rng.Borders(xlDiagonalUp).LineStyle = xlNone
        For m = 0 To UBound(Veri)
            If Range("Q1") <> Veri(m) Then
                Set Bul = Rng.Find("*" & Veri(m) & "*", , xlValues, xlWhole)
                If Not Bul Is Nothing Then
                    FrstAdr = Bul.Address
                    Do
                        AraBul = Split(Cells(Bul.Row, Bul.Column), " ")
                        For e = 0 To UBound(AraBul)
                            If AraBul(e) = Veri(m) Then
                                With Bul.Borders(xlDiagonalUp)
                                    .LineStyle = xlContinuous
                                    .ColorIndex = xlAutomatic
                                    .TintAndShade = 0
                                    .Weight = xlThin
                                End With
                                Bul.Interior.Color = vbYellow
                                Exit For
                            End If
                        Next
                        Set Bul = Rng.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> FrstAdr
                End If
            End If
        Next
    End If
End Sub

 

[1Al2Ver]

Merhaba,

İlgili konu için çözüm arayışım sürmektedir,

Teşekkür ederim.

 

[Korhan Ayhan]

Makro kullanımında GERİ AL (CTRL+Z) maalesef çalışmaz.

 

[1Al2Ver]

Sayın KorhanAyhan merhaba,

Anladım, teşekkür ederim,

Yalnız, aynı çalışma kitabımda, kod içermeyen sayfalarda da Geri Al yapamıyorum,

Saygılarımla.

 

[Korhan Ayhan]

Bu demek oluyor ki kullanılan kod tüm sayfaları etkiliyor.

 

[1Al2Ver]

Sayın Korhan Ayhan tekrar merhaba,

"Bu demek oluyor ki kullanılan kod tüm sayfaları etkiliyor."

Evet, doğrudur,

Çözümü nasıl olmalıdır ?

Teşekkür ederim.

 

[Korhan Ayhan]

Benim bildiğim kadarıyla çözümü yok maalesef...

Bir video buldum. İnceleyiniz.

 

[1Al2Ver]

Sayın Korhan Ayhan merhaba,

Bilgilendirme ve video için teşekkür ederim, sağ olun.

Benim arzum, makroyu geri almak değil, kitaptaki mevcut makronun tüm sayfaları etkileyip, Ctrl+Z "geri al" fonk. çalışmamasını engellemek,

Bu haliyle bu kodu kullanamıyorum, ancak ihtiyacımı da görüyordu, ta ki Ctrl+Z engeliyle karşılaşıncaya kadar.

Kodu revize ederek, buna engel olabilmek mümkün mü ?

Teşekkür ederim.

 

[Korhan Ayhan]

Makronun ilk satırının altına (Private ile başlayan satır) aşağıdaki satırı ekleyip bir deneyin bakalım olacak mı?

    If ActiveSheet.Name <> "TABLO" Then Exit Sub