Soru Hücreye göre filtreleme

[mcetinkaya65]

Stenizde bulduğum Yurttaş - 2012 ait bir bir çalışmada
Tablo içinde her hangi bir hücreye girince, girilen hücreye göre süzüyor. Tablo dışında her hangi bir hücreye girincede, tüm verileri gösteriyor.
Çok güzel bir çalışama
Biz bu çalışmadaki makroyu nasıl bir düzenleme yapmalıyız ki grilen hücreye girince değilde çift tıklama ile çalışsa
tabi ki mümkünse
Saygılarımla...

 

[alicimri]

Aşağıdaki kodu tablonuzun bulunduğu sekmenin modülüne yapıştırıp, deneyin

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Value <> "" Then
Sutun = Target.Column
    ActiveSheet.Columns(Sutun).AutoFilter Field:=1, Criteria1:=Target.Value
    Else
   Selection.AutoFilter
   End If
End Sub

 

[Merhum İdris SERDAR]

.

Çalışma bana ait.

Kodları, sayfanın Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) olayına yazın. Yani;

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

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

şeklinde...


.

 

[alicimri]

Yukardaki kod hata veriyor, kod ilavesi yaptım.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target.Value <> "" Then
Sutun = Target.Column
    ActiveSheet.Columns(Sutun).AutoFilter Field:=1, Criteria1:=Target.Value
    Else
   Selection.AutoFilter
   End If
End Su

 

[mcetinkaya65]

.

Çalışma bana ait.

Kodları, sayfanın Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) olayına yazın. Yani;

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

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

şeklinde...


.

Üstad Allah razı olsun.
Özür dilerim, çalışmayı çok önceden bilgisayarıma indirmiştim demek ki yanılmışım.

 

[mcetinkaya65]

Yukardaki kod hata veriyor, kod ilavesi yaptım.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target.Value <> "" Then
Sutun = Target.Column
    ActiveSheet.Columns(Sutun).AutoFilter Field:=1, Criteria1:=Target.Value
    Else
   Selection.AutoFilter
   End If
End Su

Üstad size zahmet verdik,
İhtiyarlığıma verin ama kodları çalıştıramadım.

 

[mcetinkaya65]

.

Çalışma bana ait.

Kodları, sayfanın Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) olayına yazın. Yani;

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

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

şeklinde...


.

Bu kodlar sayfayı tabloya çevirisek çalışıyor. Ama tablonun belirli bir kısmında sıralama yapacak olursak tabloyu baştan sonu sıralıyor. Bu makroyu sayfayı tabloya çvirmeden aynı mantıkla çalıştırabilirmiyiz..
Saygılarımla...

 

[Merhum İdris SERDAR]

.

Buraya bakınız.

https://www.excel.web.tr/threads/huecreden-filtreleme.200601/

.