Filtrelenmiş Verileri Tabloda Renklendirmek

[1Al2Ver]

Merhaba,

Olabiliyor ise,

Dosyada ;

A,B yada C sütununda süz işlemi gerçekleştiğinde;
Süzülenler kırmızı olsun

Süzme işlemi herhangi bir seçime göre 2 nci kez yapıldığında,
Süzülen kırmızı olsun, eskisi eski rengine (siyah) dönsün

şeklinde bir arzum var.

AMAÇ ;

En son süzülen firmayı A3:C aralığında renkli görmek

Örneklemeyi ve açıklamaları ek'li dosyada bulabilir siniz.

Teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı incelermisiniz.

Koşullu biçimlendirme ile yapılmıştır.

 

[1Al2Ver]

Merhaba,

Ekteki örnek dosyayı incelermisiniz.

Koşullu biçimlendirme ile yapılmıştır.

Sayın Korhan Ayhan merhaba,

Öncelikle duyarlığınız ve çözüm için teşekkür ederim.

İfadelerimi okuduğum zaman konuyu bire bir anlatamadığımı anladım, bu çözüm de güzel, fakat ben "tablo süzülmemişken" en son süzüleni renkli görmek istemiştim, diğer bir deyişle, dosyayı her açtığımda yada tekrar süzmem gerektiğinde bir önce hangi firmayı süzmüşüm, onu belirlemek istemiştim.

Örnek tabloda (A:C) şu an kırmızı olarak AYMAZLAR LTD.ŞTİ. var, ben bir başka firma (örn ; BAYNAK TURİZM) süzdüğümde, süzülmemiş tabloda (A3:C29) en son süzüleni (BAYNAK TURİZM) kırmızı renk görmek istiyorum.

Tekrarladığım ifadeler için kusuruma bakmayın, sizi mütemadiyen yormamak adına oldu, tekrar teşekkür ederim.

Saygılarımla.

 

[snx111]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ison = Cells(Rows.Count, 1).End(xlUp).Row + 1

If Intersect(Target, Range("b2: b" & ison)) Is Nothing Then Exit Sub
Set dizi = Range("b" & 3 & ":b" & ison)
dizi.Interior.ColorIndex = xlNone
birdaha:
Dim hcr As Range, say As Double
For Each hcr In dizi
    If hcr.Rows.Hidden = True Then x = x + 1
    Next
    If x < 1 Then Exit Sub
For Each hcr In dizi
    If hcr.Rows.Hidden = False Then
        hcr.Rows.Interior.ColorIndex = 3
       
    End If
Next
On Error Resume Next
For Each hcr In dizi
    If hcr.Rows.Hidden = True Then
       If hcr.Rows.Interior.ColorIndex <> xlNone Then
       hcr.Rows.Interior.ColorIndex = xlNone

        End If
        End If
        Next
son: sayac = sayac + 1
If sayac <= 2 Then
GoTo birdaha

End If
 Exit Sub
        
End Sub

filtre sonrası filtrelenmiş bir hücreye tıklamalısınız

 

[1Al2Ver]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ison = Cells(Rows.Count, 1).End(xlUp).Row + 1

If Intersect(Target, Range("b2: b" & ison)) Is Nothing Then Exit Sub
Set dizi = Range("b" & 3 & ":b" & ison)
dizi.Interior.ColorIndex = xlNone
birdaha:
Dim hcr As Range, say As Double
For Each hcr In dizi
    If hcr.Rows.Hidden = True Then x = x + 1
    Next
    If x < 1 Then Exit Sub
For Each hcr In dizi
    If hcr.Rows.Hidden = False Then
        hcr.Rows.Interior.ColorIndex = 3
       
    End If
Next
On Error Resume Next
For Each hcr In dizi
    If hcr.Rows.Hidden = True Then
       If hcr.Rows.Interior.ColorIndex <> xlNone Then
       hcr.Rows.Interior.ColorIndex = xlNone

        End If
        End If
        Next
son: sayac = sayac + 1
If sayac <= 2 Then
GoTo birdaha

End If
 Exit Sub
        
End Sub

filtre sonrası filtrelenmiş bir hücreye tıklamalısınız

Sayın snx111, merhaba,

Çözüm ve gösterdiğiniz ilgi için teşekkür ederim,

Saygılarımla.

 

[snx111]

Sorununuzu çözdümü acaba ?
ayrıca font rengini değil hücre dolgu rengini değiştirdim daha hızlı algılama açısından ...

 

[1Al2Ver]

Sorununuzu çözdümü acaba ?
ayrıca font rengini değil hücre dolgu rengini değiştirdim daha hızlı algılama açısından ...

Tekrar merhaba,

Sorun çözüldü, ayrıca dolgu rengi daha çarpıcı olmuş,

Tekrar teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak yardımcı hücreler, makro ve koşullu biçimlendirme kullanarak hazırladığım örnek dosyayı incelermisiniz.

Çoklu verilerde daha iyi ve hızlı sonuç alabilirsiniz.

Renkleri tamamen kaldırma için B1 hücresinin içeriğini temizlemeniz yeterlidir.

 

[nane]

Korhan bey ve snx111 ellerinize sağlık her ikisi de güzel
Teşekkürler
Yb®

 

[nane]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Application.ScreenUpdating = False

Dim hcr As Range
Dim Thcr As Boolean
Dim sut As Single

On Error Resume Next
Set hcr = Selection
Thcr = (hcr.ListObject.Name <> "")

On Error GoTo 0

If Thcr = False Then
For i = 1 To ActiveSheet.ListObjects.Count
For j = 1 To ActiveSheet.ListObjects(i).Range.Columns.Count
ActiveSheet.ListObjects(i).Range.AutoFilter Field:=j
Next j
Next i
Exit Sub
End If

If Selection.Cells.Count > 1 Then Exit Sub
sut = Selection.Column - hcr.ListObject.Range.Column + 1

ActiveSheet.ListObjects(hcr.ListObject.Name).Range.AutoFilter _
Field:=sut, Criteria1:="=" & Selection

Application.ScreenUpdating = True

End Sub


Merhabalar snx111,
Aynı sayfada bulunan yukarıda YURTTAŞ beyin vermiş olduğu kod var bununla birlikte sizin verdiğiniz kodu kollanmak istediğimde kod çakışması oluyor. Bunu nasıl düzeltebilirim.
Yardımınızı bekliyorum
Teşekkürler...
Yb®

 

[snx111]

örnek dosya ve bu kodlar ne iş yapar ?

 

[nane]

örnek dosya ve bu kodlar ne iş yapar ?

B6 ile H6...H1500..n hücreleri arasındaki verilerin üzerine tıklandığında o veri grubunu süzüyor.

İlgili sütundaki yani B, C, D, E, ...H sütunlarındaki ger gurubu ayrı ayrı süzuyor.
İlginize teşekkürler...
Yb®