Фильтрация таблицы Excel

Option Explicit
' based on macros written by Ken Puls
' www.exelguru.ca
' edited by Fatty 29/04/07
Private Sub SortByFirstColumn(ByVal rang As Range, ByVal order As Integer)
     rang.Activate
     rang.Select
     With Selection
          .Sort Key1:=Range("A1"), Order1:=order, Header:=xlGuess, _
                OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                DataOption1:=xlSortNormal
     End With
     Cells(1, 1).Select
End Sub
Public Sub SortDiapazone()
' Force to late Excel binding
' (with early biding works also)
     Dim xlApp As Object 'Excel.Application
     Dim xlBook As Object 'Excel.Workbook
     Dim xlSheet As Object 'Excel.Worksheet
' Specify the sort order
     Dim shift As String
     shift = InputBox(vbCrLf & "Enter a sorting order of the column" & vbCrLf & _
                      "(1 - by acsending,2 - by descending)", "Sorting Order", "2")
     Dim order As Integer
     order = CInt(shift)
     On Error Resume Next
     ' Clear any errors
     Err.Clear
     ' See if Excel is running
     Set xlApp = GetObject(, "Excel.application")
     ' If Excel not running start a new session
     If Err <> 0 Then
          Err.Clear
          ' Start Excel if excel is not running
          Set xlApp = CreateObject("Excel.application")
          If Err <> 0 Then
               MsgBox " Could not start Excel ! , Is Excel Installed ? ", vbCritical, " Excel Error ! "
               Err.Clear
          End If
     End If
     Err.Clear
     On Error GoTo Err_Control
     ' Make excel application visible
     xlApp.Visible = True
     ' Minimize application window so we don't see it
     ' (optional, change by suit)
     xlApp.WindowState = xlMinimized
     ' Make Autocad window maximum
     AcadApplication.WindowState = acMax
     ' Open the desired book
     Set xlBook = xlApp.Workbooks.Open(FileName:="D:\Temp\table.xls")'// имя файла изменить
     MsgBox xlBook.Name     '// debug only
     Set xlSheet = xlBook.Worksheets("Sheet1") '// имя листа изменить
     ' Make sheet 1 the active sheet
     If Not xlSheet Is Nothing Then
          xlSheet.Activate
     Else
          MsgBox "The work sheet " & """Sorted""" & " not found" & vbCrLf & _
                 "Exit by error occurance."
          GoTo Exit_Here
     End If
     ' Sort the first column by defined criteria
     Dim rang As Range
     Set rang = xlSheet.UsedRange
     Call SortByFirstColumn(rang, order)
Exit_Here:
     Set xlSheet = Nothing
     xlBook.Save
     xlBook.Close
     Set xlBook = Nothing
     xlApp.WindowState = xlMaximized
     xlApp.Quit
     Set xlApp = Nothing
     Exit Sub
Err_Control:
  If Err.Number <> 0 Then
  MsgBox Err.Description
     ' Close book and clean up
     xlBook.Save
     xlBook.Close     '//Savechanges:=True
     xlApp.WindowState = xlMaximized
     xlApp.Quit
End If
End Sub

Option Explicit
Private Sub CommandButton1_Click()
     Unload Me
End Sub
Private Sub UserForm_Initialize()
     ListBox1.ColumnCount = 2
     ListBox1.BoundColumn = 1
     ListBox1.Clear
     Dim coll As New Collection
     ' get data by filtering
     Set coll = QueryTable()
     MsgBox "Íàéäåíî ñîîòâåòñòâèé: " & coll.Count
     If coll.Count > 0 Then
          Dim i As Integer
          ReDim arr(coll.Count - 1, 1) As String
          ' convert collection to multi-dimensional array
          For i = 1 To coll.Count
               arr(i - 1, 0) = coll.Item(i)(0)
               arr(i - 1, 1) = coll.Item(i)(1)
          Next
          ' populate listbox with array items
          ListBox1.List() = arr
     Else
          ' exception message
          MsgBox "Íåò ñòðîê ñ òàêèìè íîìåðàìè"
          End
     End If
End Sub
Public Function QueryTable() As Collection
' Force to late Excel binding
' (with early biding works also)
     Dim xlApp As Excel.Application
     Dim xlBook As Excel.Workbook
     Dim xlSheet As Excel.Worksheet
     ' Specify the sort num
     Dim shift As String
     shift = InputBox(vbCrLf & "Ââåäèòå íîìåð èçäåëèÿ" & vbCrLf & _
                      "äëÿ âûáîðêè èç ñïèñêà:", "Ïîçèöèÿ")
     On Error Resume Next
     ' Clear any errors
     Err.Clear
     ' See if Excel is running
     Set xlApp = GetObject(, "Excel.application")
     ' If Excel not running start a new session
     If Err <> 0 Then
          Err.Clear
          ' Start Excel if excel is not running
          Set xlApp = CreateObject("Excel.application")
          If Err <> 0 Then
               MsgBox " Could not start Excel ! , Is Excel Installed ? ", vbCritical, " Excel Error ! "
               Err.Clear
          End If
     End If
     Err.Clear
     On Error GoTo Err_Control
     ' Make excel application visible
     xlApp.Visible = True
     ' Minimize application window so we don't see it
     ' (optional, change by suit)
     xlApp.WindowState = xlMinimized
     ' Make Autocad window maximum
     AcadApplication.WindowState = acMax
     ' Open the desired book
     Set xlBook = xlApp.Workbooks.Open(FileName:="D:\AUTOLISP\LISPS\PRIMITIVES\#EXCEL\table.xls")
     '//MsgBox xlBook.Name     '// debug only
     Set xlSheet = xlBook.Worksheets(1)
     ' Make sheet 1 the active sheet
     If Not xlSheet Is Nothing Then
          xlSheet.Activate
     Else
          MsgBox "The work sheet " & """Sorted""" & " not found" & vbCrLf & _
                 "Exit by error occurance."
          GoTo Exit_Here
     End If
     Dim rang As Range
     Set rang = xlSheet.UsedRange
     rang.Select
     Dim target As Range
     Set target = rang.Range(Cells(1, 1), Cells(rang.Rows.Count, 1))
     target.Activate
     target.Select
     '//Debug.Print "Rows " & rang.Rows.Count'//
     Dim coll As Collection
     Set coll = New Collection
     Dim i As Long
     For i = 1 To target.Rows.Count
          Dim found As Range
          Set found = target.Cells(i, 1)
          '
          If CStr(found.Value) = shift Then
               Dim tmp(1) As String
               tmp(0) = CStr(found.Value)
               tmp(1) = CStr(found.Offset(0, 1).Value)
               coll.Add tmp
          End If
     Next
Exit_Here:
     Set xlSheet = Nothing
     xlBook.Save
     xlBook.Close
     Set xlBook = Nothing
     xlApp.WindowState = xlMaximized
     xlApp.Quit
     Set xlApp = Nothing
Err_Control:
     If Err.Number <> 0 Then
          MsgBox Err.Description
          ' Close book and clean up
          xlBook.Save
          xlBook.Close     '//Savechanges:=True
          xlApp.WindowState = xlMaximized
          xlApp.Quit
     End If
     Set QueryTable = coll
End Function