Hücre Seçerek Filtreleme

[izcik]

Merhaba

Ekte, Sayın Korhan Ayhan uzmanımızın kodlarıyla oluşturmuş olduğum örnek dosya vardır.

1. satırdaki kelimelere göre hatasızca filtreleme yapmaktadır. 2. , 3. veya oluşturduğum diğer satırlardaki kelimelere göre de filtreleme yapmasını istemekteyim.

(örnek vermem gerekirse, sadece C1 i tıkladığımda C1 e göre filtreleme yapması gerekir. Hem C1 e hem de K4 e tıkladığımda ikisine göre filtreleme yapması gerekir.)

(Birden fazla tıklama olayını, Ctrl düğmesine basarak yapılacak şekilde düşünebiliriz)


Ayrıca bu soru çözülünce bu konuyla ilgili bir-iki sorum daha olacak.

Teşekkürler

cicek.xlsm dosyasını indir - download

cicek.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

Amacım hücrelere tıklayarak yani hücreleri seçerek, istediğim şekilde filtrelemeyi hızlıca yapabilmektir.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Veri As Range, Say1 As Long, Say2 As Long, Say3 As Long, Say4 As Long
   
    Application.ScreenUpdating = False
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    Application.ScreenUpdating = True
   
    If Intersect(Target, Range("B1:AZ4")) Is Nothing Then Exit Sub
   
    Application.ScreenUpdating = False
   
    ReDim Liste1(1 To 1)
    ReDim Liste2(1 To 1)
    ReDim Liste3(1 To 1)
    ReDim Liste4(1 To 1)
   
    For Each Veri In Selection
        Select Case Veri.Row
            Case 1
            If Veri.Value <> "" Then
                Say1 = Say1 + 1
                ReDim Preserve Liste1(1 To Say1)
                Liste1(Say1) = CStr(Veri.Value)
            End If
            Case 2
            If Veri.Value <> "" Then
                Say2 = Say2 + 1
                ReDim Preserve Liste2(1 To Say2)
                Liste2(Say2) = CStr(Veri.Value)
            End If
            Case 3
            If Veri.Value <> "" Then
                Say3 = Say3 + 1
                ReDim Preserve Liste3(1 To Say3)
                Liste3(Say3) = CStr(Veri.Value)
            End If
            Case 4
            If Veri.Value <> "" Then
                Say4 = Say4 + 1
                ReDim Preserve Liste4(1 To Say4)
                Liste4(Say4) = CStr(Veri.Value)
            End If
        End Select
    Next

    With Range("A8:G" & Rows.Count)
        If Say1 > 0 Then .AutoFilter 3, Criteria1:=Liste1, Operator:=xlFilterValues
        If Say2 > 0 Then .AutoFilter 4, Criteria1:=Liste2, Operator:=xlFilterValues
        If Say3 > 0 Then .AutoFilter 6, Criteria1:=Liste3, Operator:=xlFilterValues
        If Say4 > 0 Then .AutoFilter 7, Criteria1:=Liste4, Operator:=xlFilterValues
    End With
   
    Application.ScreenUpdating = True
End Sub

 

[izcik]

Uzmanım kelimenin tam anlamıyla ömürlük ve kusursuz kod yazmışsınız. Ömrüm yettiğince muhafaza edeceğim.

İlave olarak şunu soracaktım, diyecektim ki:
“Aynı satırda birden fazla hücreyi seçebiliyor muyuz” diyecektim. Denedim, seçilebiliyor. İkinci soruya gerek bile kalmadı.
Emeğinize fikrinize sağlık uzmanım.

 

[Korhan Ayhan]

En son satırdaki "Son" yazan bölümü revize ettim. Önceki koddan kalmıştı. Atlamışım.