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

Collapse
X
 
  • زمان
  • نمایش
حذف همه
new posts
  • Amir Ghasemiyan

    • 2013/09/20
    • 4571
    • 100.00

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

    سلام دوستان.

    تو اين آموزش ميخوام بهتون ياد بدم چطور ميتونين با كمك ليستي كه از طريق 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 رو بهتره از طريق فايل پيگيري كنيد.
    فایل های پیوست شده
    Last edited by Amir Ghasemiyan; 2014/09/22, 05:06.
  • Amir Ghasemiyan

    • 2013/09/20
    • 4571
    • 100.00

    #2
    در آموزش بالا فيلتر بر اساس نام صورت ميگيره، اما حالا ميخوايم كمي پا رو فراتر بذاريم و انتخاب موضوع فيلتر رو هم به عهده كاربر بذاريم.
    خب من فقط كدها رو ميذارم و بقيه اطلاعات رو از فايل پيوست استخراج كنيد
    اين كد رو در قسمت كدهاي تب 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

      • 2013/09/20
      • 4571
      • 100.00

      #3
      خب بعد از اينكه انتخاب موضوع رو هم اضافه كرديم، حالا ميخوايم فيلتر متن رو هم اضافه كنيم. به اين معني كه ليستمون رو محدود به عباراتي كنيم كه با يك حرف يا كلمه خاص شروع ميشن.
      براي اين كار در قسمت كدهاي تب 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
        مدير تالار اکسل و بانک اطلاعاتی

        • 2011/02/06
        • 1805
        • 74.00

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

        با تشکر از استاد گرامی امیر خان قاسمیان بابت آموزش بسیار کاربردیشون
        تو فایل زیر شما می تونید تنها با یک کلیک ، روی هر سل در ستون مورد نظر ، اطلاعات را بر اون اساس فیلتر کرد.
        در ضمن با کلیک بر سل 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(lRowlCol)
            Else
                
        rngFS.Value "On"
                
        Call HideArrows(lRowlCol)
            
        End If
          
        rngFS.Offset(10).Activate
        End 
        If

        If 
        UCase(rngFS.Value) = "ON" Then
            
        If Not Intersect(TargetrngFIs Nothing Then
                
        If Target.Row lRow Then
                  rngF
        .AutoFilter Field:=Target.Column lCol_
                      Criteria1
        :=Target.Value
                    Cells
        (lRowTarget.Column).Interior.ColorIndex 36
                
        ElseIf Target.Row lRow Then
                    rngF
        .AutoFilter Field:=Target.Column lCol
                    Cells
        (lRowTarget.Column).Interior.ColorIndex xlNone
                End 
        If
            
        End If
        End If
        exitHandler:
        Exit 
        Sub

        End Sub


        Sub HideArrows
        (lRow As LonglCol As Long)
        Dim c As Range
        Dim i 
        As Integer
        Cells(lRowlCol 1).End(xlToRight).Column
        Application
        .ScreenUpdating False
        For Each c In Range(Cells(lRowlCol 1), Cells(lRowlCol i))
         
        c.AutoFilter Field:=c.Column_
            Visibledropdown
        :=False
          c
        .Interior.ColorIndex xlNone
        Next
        Application
        .ScreenUpdating True
        End Sub


        Sub ShowArrows
        (lRow As LonglCol As Long)
        Dim c As Range
        Dim i 
        As Integer
        Cells(lRowlCol 1).End(xlToRight).Column
        Application
        .ScreenUpdating False
        For Each c In Range(Cells(lRowlCol 1), Cells(lRowlCol i))
         
        c.AutoFilter Field:=c.Column_
            Visibledropdown
        :=True
          c
        .Interior.ColorIndex xlNone
        Next
        Application
        .ScreenUpdating True
        End Sub 
        فایل های پیوست شده
        [CENTER][IMG]http://forum.exceliran.com/signaturepics/sigpic909_10.gif[/IMG]
        [/CENTER]

        کامنت

        • sabertb

          • 2014/04/09
          • 347
          • 45.00

          #5
          سلام خسته نباشید خیلی خیلی خوب بود متشکرم
          میشه چندین آیتم برای فیلتر قرار داد ؟ هم بر اساس نام هم بر اساس چند آیتم دیگه ؟
          آیا میشود با ایجاد تغییر در لیست ظاهر شده دیتا بیسمون هم تغییر داد ؟
          :min10::min18::min13::min22:

          کامنت

          • sabertb

            • 2014/04/09
            • 347
            • 45.00

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

            کامنت

            • ehsanshahbeig

              • 2017/01/21
              • 45
              • 28.00

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

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

              کامنت

              • sabertb

                • 2014/04/09
                • 347
                • 45.00

                #8
                منظورشان نوار ابزار قسمت Formulas است و قسمت Name Manage در این قسمت دامنه ها نام گذاری می شود که در ماژول ها مورد استفاده قرار میگیرد
                Click image for larger version

Name:	11.jpg
Views:	1
Size:	286.6 کیلو بایت
ID:	134245
                :min10::min18::min13::min22:

                کامنت

                • ehsanshahbeig

                  • 2017/01/21
                  • 45
                  • 28.00

                  #9
                  نوشته اصلی توسط sabertb
                  منظورشان نوار ابزار قسمت Formulas است و قسمت Name Manage در این قسمت دامنه ها نام گذاری می شود که در ماژول ها مورد استفاده قرار میگیرد
                  [ATTACH=CONFIG]17052[/ATTACH]
                  بله میدونم. فقط چجوری میشه تو بخش گزارشات. اون سرستونهایی که برای گزارش هست رو تغییر داد؟

                  کامنت

                  • ehsanshahbeig

                    • 2017/01/21
                    • 45
                    • 28.00

                    #10

                    کامنت

                    چند لحظه..