Renklendir, Kritere Göre

1Al2Ver

Altın Üye
Katılım
5 Kasım 2007
Mesajlar
4,708
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

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,520
Excel Vers. ve Dili
Office 365 Türkçe
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
 

1Al2Ver

Altın Üye
Katılım
5 Kasım 2007
Mesajlar
4,708
Excel Vers. ve Dili
64 Bit TR - Microsoft Office 365 - Win11 Home
Sayın EmrExcel16 merhaba,

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

Saygılarımla.
 

1Al2Ver

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

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
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
 

1Al2Ver

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

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
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
 

1Al2Ver

Altın Üye
Katılım
5 Kasım 2007
Mesajlar
4,708
Excel Vers. ve Dili
64 Bit TR - Microsoft Office 365 - Win11 Home
Sayın YUSUF44 tekrar merhaba,

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

Kandiliniz kutlu olsun,

Saygılarımla.
 

1Al2Ver

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

1Al2Ver

Altın Üye
Katılım
5 Kasım 2007
Mesajlar
4,708
Excel Vers. ve Dili
64 Bit TR - Microsoft Office 365 - Win11 Home
Merhaba,

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

Teşekkür ederim.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Makro kullanımında GERİ AL (CTRL+Z) maalesef çalışmaz.
 

1Al2Ver

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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu demek oluyor ki kullanılan kod tüm sayfaları etkiliyor.
 

1Al2Ver

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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Benim bildiğim kadarıyla çözümü yok maalesef...

Bir video buldum. İnceleyiniz.

 

1Al2Ver

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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 
Üst