فيلتر كردن از طريق ليست

[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]

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

[sabertb]

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

[ehsanshahbeig]

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

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

[sabertb]

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

[ehsanshahbeig]

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

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

[ehsanshahbeig]