با تشکر از استاد گرامی امیر خان قاسمیان بابت آموزش بسیار کاربردیشون
تو فایل زیر شما می تونید تنها با یک کلیک ، روی هر سل در ستون مورد نظر ، اطلاعات را بر اون اساس فیلتر کرد.
در ضمن با کلیک بر سل J1 ، می تونید این حالت را off یا بر عکس on بکنید .
اطلاعات زیر را تو ورک شیت مورد نظر کپی کنید
کد PHP:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngF As Range
Dim rngFS As Range
Dim lRow As Long
Dim lCol As Long
Set rngF = ActiveSheet.AutoFilter.Range
Set rngFS = ActiveSheet.Range("FilterStatus")
lCol = rngF.Columns(1).Column - 1
lRow = rngF.Columns(1).Row
If Target.Count > 1 Then GoTo exitHandler
If Target.Address = rngFS.Address Then
If rngFS.Value = "On" Then
rngFS.Value = "Off"
Call ShowArrows(lRow, lCol)
Else
rngFS.Value = "On"
Call HideArrows(lRow, lCol)
End If
rngFS.Offset(1, 0).Activate
End If
If UCase(rngFS.Value) = "ON" Then
If Not Intersect(Target, rngF) Is Nothing Then
If Target.Row > lRow Then
rngF.AutoFilter Field:=Target.Column - lCol, _
Criteria1:=Target.Value
Cells(lRow, Target.Column).Interior.ColorIndex = 36
ElseIf Target.Row = lRow Then
rngF.AutoFilter Field:=Target.Column - lCol
Cells(lRow, Target.Column).Interior.ColorIndex = xlNone
End If
End If
End If
exitHandler:
Exit Sub
End Sub
Sub HideArrows(lRow As Long, lCol As Long)
Dim c As Range
Dim i As Integer
i = Cells(lRow, lCol + 1).End(xlToRight).Column
Application.ScreenUpdating = False
For Each c In Range(Cells(lRow, lCol + 1), Cells(lRow, lCol + i))
c.AutoFilter Field:=c.Column, _
Visibledropdown:=False
c.Interior.ColorIndex = xlNone
Next
Application.ScreenUpdating = True
End Sub
Sub ShowArrows(lRow As Long, lCol As Long)
Dim c As Range
Dim i As Integer
i = Cells(lRow, lCol + 1).End(xlToRight).Column
Application.ScreenUpdating = False
For Each c In Range(Cells(lRow, lCol + 1), Cells(lRow, lCol + i))
c.AutoFilter Field:=c.Column, _
Visibledropdown:=True
c.Interior.ColorIndex = xlNone
Next
Application.ScreenUpdating = True
End Sub
علاقه مندی ها (Bookmarks)