• DİKKAT

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

Renklendir, Kritere Göre

  • Konbuyu başlatan Konbuyu başlatan 1Al2Ver
  • Başlangıç tarihi Başlangıç tarihi
1Al2Ver

1Al2Ver

Katılım
5 Kasım 2007
Mesajlar
4,727
Excel Vers. ve Dili
64 Bit TR - Microsoft Office 365 - Win11 Home
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.
 

Ekli dosyalar

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

Kod: 
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
 
Sayın EmrExcel16 merhaba,

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

Saygılarımla.
 
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.
 

Ekli dosyalar

Aşağıdaki kodu deneyiniz:

PHP: 
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
 
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.
 
Aşağıdaki gibi oldu galiba:

PHP: 
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
 
Sayın YUSUF44 tekrar merhaba,

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

Kandiliniz kutlu olsun,

Saygılarımla.
 
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.

Kod: 
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
 
Merhaba,

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

Teşekkür ederim.
 
Makro kullanımında GERİ AL (CTRL+Z) maalesef çalışmaz.
 
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.
 
Bu demek oluyor ki kullanılan kod tüm sayfaları etkiliyor.
 
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.
 
Benim bildiğim kadarıyla çözümü yok maalesef...

Bir video buldum. İnceleyiniz.

 
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.
 
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ı?

Kod: 
    If ActiveSheet.Name <> "TABLO" Then Exit Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst