آموزشی فيلتر كردن از طريق ليست

[Amir Ghasemiyan]

سلام دوستان.

تو اين آموزش ميخوام بهتون ياد بدم چطور ميتونين با كمك ليستي كه از طريق Data Validation ساخته شده، يك فيلتر ايجاد كنيد.

از ساده ترين حالت شروع ميكنم:

فرض كنيد ما يكسري اطلاعات در يك جدول و در تب Data داريم و ميخوايم يكسري از اين اطلاعات رو مثلا نام و تاريخ و قيمت نهايي رو (به بقيه داده هاي جدول اصلي كاري نداريم) بر اساس نام فيلتر كنيم. يعني وقتي ما نام مورد نظر رو انتخاب كرديم سيستم اطلاعاتي كه لازم داريم (نام و تاريخ و قيمت نهايي) رو برامون بياره

در تب Excel Iran اين كدها رو وارد ميكنيم:

Private Sub Worksheet_Change(ByVal Target As Range)If Target.Address = "$C$8" Then
    Dim wsSD As Worksheet
    Dim wsS As Worksheet
    On Error GoTo errHandler
    Set wsSD = Sheets("Data")
    Set wsS = Sheets("Excel Iran")
    Application.EnableEvents = False
    
    If Target.Value = "" Then
        Call OrderSort("CriteriaName", True)
    Else
        Call OrderSort("CriteriaName", False)
    End If


exitHandler:
    Application.EnableEvents = True
        Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler
End If
End Sub

و حالا يك ماژول ميسازيم و اطلاعات زير رو توش كپي ميكنيم:

Sub OrderSort(strExt As String, isempty As Boolean)
Dim wsSD As Worksheet
Dim wsS As Worksheet
On Error GoTo errHandler
Set wsSD = Sheets("Data")
Set wsS = Sheets("Excel Iran")


If isempty Then
    wsSD.Range("OrdersData").AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=wsS.Range("ExtractOrders"), Unique:=True
Else
    wsSD.Range("OrdersData").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=wsSD.Range(strExt), _
        CopyToRange:=wsS.Range("ExtractOrders"), Unique:=True
End If
exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler


End Sub

بقيه اطلاعات از قبيل name manager و Data Validation رو بهتره از طريق فايل پيگيري كنيد.

[Amir Ghasemiyan]

در آموزش بالا فيلتر بر اساس نام صورت ميگيره، اما حالا ميخوايم كمي پا رو فراتر بذاريم و انتخاب موضوع فيلتر رو هم به عهده كاربر بذاريم.
خب من فقط كدها رو ميذارم و بقيه اطلاعات رو از فايل پيوست استخراج كنيد
اين كد رو در قسمت كدهاي تب Excel Iran ميذاريم:

Private Sub Worksheet_Change(ByVal Target As Range)Dim wsSD As Worksheet
Dim wsS As Worksheet
On Error GoTo errHandler
Set wsSD = Sheets("Data")
Set wsS = Sheets("Excel Iran")
Application.EnableEvents = False


If Target.Address = "$C$8" Then
    wsS.Range("D8").ClearContents
    With wsSD.Range("ExtractNames")
        .EntireColumn.ClearContents
        .Cells(1, 1).Value = wsS.Range("Type").Value
    End With
    With wsSD
        .Range("OrdersData").AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=.Range("ExtractNames"), Unique:=True


        .Range("ExtractNames").CurrentRegion.Sort _
            Key1:=.Range("ExtractNames"), _
            Order1:=xlAscending, _
            Header:=xlGuess
    End With


ElseIf Target.Address = "$D$8" Then
    If Target.Value = "" Then
        Call OrderSort("CriteriaName", True)
    Else
        Call OrderSort("CriteriaName", False)
    End If


End If


Application.EnableEvents = True
exitHandler:
        Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler
End Sub

و يك ماژول درست ميكنيم و اطلاعات زير رو توش كپي ميكنيم:

Sub OrderSort(strExt As String, isempty As Boolean)
Dim wsSD As Worksheet
Dim wsS As Worksheet
On Error GoTo errHandler
Set wsSD = Sheets("Data")
Set wsS = Sheets("Excel Iran")


If isempty Then
    wsSD.Range("OrdersData").AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=wsS.Range("ExtractOrders"), Unique:=True
Else
    wsSD.Range("OrdersData").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=wsSD.Range(strExt), _
        CopyToRange:=wsS.Range("ExtractOrders"), Unique:=True
End If
exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler


End Sub

بقيه اطلاعات از قبيل name manager و Data Validation رو از طريق فايل استخراج كنيد

[Amir Ghasemiyan]

خب بعد از اينكه انتخاب موضوع رو هم اضافه كرديم، حالا ميخوايم فيلتر متن رو هم اضافه كنيم. به اين معني كه ليستمون رو محدود به عباراتي كنيم كه با يك حرف يا كلمه خاص شروع ميشن.
براي اين كار در قسمت كدهاي تب Excel Iran اين كد رو وارد ميكنيم:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsSD As Worksheet
Dim wsS As Worksheet
On Error GoTo errHandler
Set wsSD = Sheets("Data")
Set wsS = Sheets("Excel Iran")
Application.EnableEvents = False

If Target.Address = "$C$8" Then
    Target.Offset(0, 1).ClearContents
    Target.Offset(0, 2).ClearContents
    Call NameSort("CriteriaLetter", True)
ElseIf Target.Address = "$D$8" Then
    Target.Offset(0, 1).ClearContents
    Call NameSort("CriteriaLetter", False)
ElseIf Target.Address = "$E$8" Then
    If Target.Value = "" Then
        Call OrderSort("CriteriaName", True)
    Else
        Call OrderSort("CriteriaName", False)
    End If

End If

Application.EnableEvents = True
exitHandler:
        Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler
End Sub

و يك ماژول هم ميسازيم و اين كدها رو بهش اضافه ميكنيم:

Sub OrderSort(strExt As String, isempty As Boolean)
Dim wsSD As Worksheet
Dim wsS As Worksheet
On Error GoTo errHandler
Set wsSD = Sheets("Data")
Set wsS = Sheets("Excel Iran")

If isempty Then
    wsSD.Range("OrdersData").AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=wsS.Range("ExtractOrders"), Unique:=True
Else
    wsSD.Range("OrdersData").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=wsSD.Range(strExt), _
        CopyToRange:=wsS.Range("ExtractOrders"), Unique:=True
End If
exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler

End Sub

Sub NameSort(strExt As String, isblank As Boolean)
Dim wsSD As Worksheet
Dim wsS As Worksheet
On Error GoTo errHandler
Set wsSD = Sheets("Data")
Set wsS = Sheets("Excel Iran")

wsS.Range("Letter").Value = UCase(wsS.Range("Letter").Value)
With wsSD.Range("ExtractNames")
    .EntireColumn.ClearContents
    .Cells(1, 1).Value = wsS.Range("Type").Value
End With
With wsSD
    If isblank Then
        .Range("L2").ClearContents
        .Range("OrdersData").AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=.Range("ExtractNames"), Unique:=True
            
        .Range("ExtractNames").CurrentRegion.Sort _
            Key1:=.Range("ExtractNames"), _
            Order1:=xlAscending, _
            Header:=xlGuess
    Else
        .Range("L2").Value = wsS.Range("Letter").Value
        .Range("OrdersData").AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=wsSD.Range(strExt), _
            CopyToRange:=.Range("ExtractNames"), Unique:=True
            
        .Range("ExtractNames").CurrentRegion.Sort _
            Key1:=.Range("ExtractNames"), _
            Order1:=xlAscending, _
            Header:=xlGuess
    End If
End With

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not filter orders"
    Resume exitHandler

End Sub

بقيه اطلاعات از قبيل name manager و Data Validation رو از طريق فايلي كه پيوست ميكنم استخراج كنيد

[mokaram]

فیلتر کردن با یک کلیک

با تشکر از استاد گرامی امیر خان قاسمیان بابت آموزش بسیار کاربردیشون
تو فایل زیر شما می تونید تنها با یک کلیک ، روی هر سل در ستون مورد نظر ، اطلاعات را بر اون اساس فیلتر کرد.
در ضمن با کلیک بر سل J1 ، می تونید این حالت را off یا بر عکس on بکنید .
اطلاعات زیر را تو ورک شیت مورد نظر کپی کنید

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 

[sabertb]

سلام خسته نباشید خیلی خیلی خوب بود متشکرم
میشه چندین آیتم برای فیلتر قرار داد ؟ هم بر اساس نام هم بر اساس چند آیتم دیگه ؟
آیا میشود با ایجاد تغییر در لیست ظاهر شده دیتا بیسمون هم تغییر داد ؟

[sabertb]

بسیار بسیار عالی
شبیه کاری که استاد قاسمیان ایجاد کردن امکانش هست برای data base های خارج از اون فایل Excel ی که توش فیلتر انجام میشه ایجاد کرد ؟
مثلا من یه فایل دارم از سطر اول تا 100000 ام به تعداد 15 ستون اطلاعات هست ولی این فایل تو شبکه موجوده و من می خوام این کدنویسی همین کار رو که استاد قاسمیان انجام دادند تو سیستم خودم انجام بدم امکانش هست ؟

[ehsanshahbeig]

سلام. ممنون از آموزش خوبتون. فقط اونجا که گفتید بقیه ی چیزها رو از name manager اینا خودتون به دست بیارید. چون من زیاد آشنایی ندارم. میتونید بیشتر توضیح بدید؟

چون من الان میخوام تو قیمت فیلتر کردن به جای name,date,item,total ستون های دیگری رو قرار بدم. مثلا به جای total میخوام بزارم unit cost
چجوری باید اینکار رو بکنم؟

[sabertb]

منظورشان نوار ابزار قسمت Formulas است و قسمت Name Manage در این قسمت دامنه ها نام گذاری می شود که در ماژول ها مورد استفاده قرار میگیرد

[ehsanshahbeig]

منظورشان نوار ابزار قسمت Formulas است و قسمت Name Manage در این قسمت دامنه ها نام گذاری می شود که در ماژول ها مورد استفاده قرار میگیرد
[ATTACH=CONFIG]17052[/ATTACH]

بله میدونم. فقط چجوری میشه تو بخش گزارشات. اون سرستونهایی که برای گزارش هست رو تغییر داد؟

[ehsanshahbeig]