取过滤数据

Sub RetrieveFilterData()
 
    ' Define constants.
    
    ' Lookup
    Const LKP_SHEET As String = "Items"
    Const LKP_TABLE As Variant = 1 ' or e.g. "Items"
    Const LKP_COLUMN As Variant = "Items"
    ' Source
    Const SRC_SHEET As String = "Data"
    ' Destination
    Const DST_SHEET As String = "Stats"
    Const DST_TABLE As String = "Stats"
    Dim dColumns(): dColumns = VBA.Array(1, 2, 3, 4)
 
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the lookup range (the filtered rows in the lookup column).
    
    Dim lws As Worksheet: Set lws = wb.Sheets(LKP_SHEET)
    Dim llo As ListObject: Set llo = lws.ListObjects(LKP_TABLE)
    Dim llc As ListColumn: Set llc = llo.ListColumns(LKP_COLUMN)
    Dim lrg As Range
    On Error Resume Next
        Set lrg = llc.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' Reference the source worksheet.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    
    ' Delete the destination worksheet.
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = wb.Sheets(DST_SHEET)
    On Error GoTo 0
    If Not dws Is Nothing Then
        Application.DisplayAlerts = False
            dws.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Copy the source as the destination worksheet.
    
    sws.Copy After:=wb.Sheets(wb.Sheets.Count)
    Set dws = wb.Sheets(wb.Sheets.Count)
    dws.Name = DST_SHEET
    ' Assuming the 1st source or destination table:
    Dim dlo As ListObject: Set dlo = dws.ListObjects(1)
    dlo.Name = DST_TABLE
    ' Clear filters.
    If dlo.ShowAutoFilter Then
        If dlo.AutoFilter.FilterMode Then
            dlo.AutoFilter.ShowAllData
        End If
    End If
    
    ' If nothing was filtered.
    
    If lrg Is Nothing Then
        dlo.DataBodyRange.Delete
        MsgBox "Nothing to lookup.", vbExclamation
        Exit Sub
    End If
        
    ' Write the filtered strings to a dictionary.
    
    Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
    lDict.CompareMode = vbTextCompare
        
    Dim lCell As Range, lStr As String
    For Each lCell In lrg.Cells
        lStr = CStr(lCell.Value)
        If Len(lStr) > 0 Then
            If Not lDict.Exists(lStr) Then
                lDict(lStr) = Empty
            End If
        End If
    Next lCell
        
    If lDict.Count = 0 Then
        dlo.DataBodyRange.Delete
        MsgBox "Only blanks found.", vbCritical
        Exit Sub
    End If
        
    ' Write the source or destination data to an array.
        
    Dim drg As Range: Set drg = dlo.DataBodyRange
    Dim dData(): dData = drg.Value
    
    ' Write the matching data to the top of the array.
    
    Dim nUpper As Long: nUpper = UBound(dColumns)
    Dim rCount As Long: rCount = UBound(dData, 1)
    Dim cCount As Long: cCount = UBound(dData, 2)
    
    Dim lKey, r As Long, dr As Long, c As Long, n As Long
    Dim dStr As String, IsNotFound As Boolean
    
    For r = 1 To rCount
        For Each lKey In lDict.Keys
            For n = 0 To nUpper
                c = dColumns(n)
                dStr = dData(r, c)
                If StrComp(dStr, lKey, vbTextCompare) = 0 Then
                    Exit For
                End If
            Next n
            If n > nUpper Then
                IsNotFound = True
                Exit For
            End If
        Next lKey
        If IsNotFound Then
            IsNotFound = False
        Else
            dr = dr + 1
            For c = 1 To cCount
                dData(dr, c) = dData(r, c)
            Next c
        End If
    Next r
                
    If dr = 0 Then
        dlo.DataBodyRange.Delete
        MsgBox "No matches found.", vbExclamation
        Exit Sub
    End If
    
    ' Write the matching data from the top of the array
    ' to the destination table.
    
    drg.Resize(dr, cCount).Value = dData
    
    ' Delete the remaining (table) rows.
    
    If dr < rCount Then
        drg.Resize(rCount - dr).Offset(dr).Delete xlShiftUp
    End If

    ' Inform.
   
    MsgBox "Filtered data retrieved.", vbInformation
    
End Sub

一步一步在一个子

Option Explicit

Private Sub doTheCopy()
   Dim datat As ListObject, vis As Range, ar As Range, tar As Range
   Dim statWs As Worksheet, dataWS As Worksheet
   Dim lbr As Long, ubr As Long, lbc As Long, ubc As Long, rr As Long, cc As Long, fcnt As Integer, haveToFind As Integer
   Dim arr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
   Const char160 = " "
   
   'FIND THE VISIBLE AREA
   Set vis = Me.ListObjects("ItemsTable").DataBodyRange.SpecialCells(xlCellTypeVisible)
   If vis Is Nothing Then Exit Sub
   
   'GET THE TWO OTHER SHEETS
   On Error Resume Next
   Set dataWS = Worksheets("Data")
   Set statWs = Worksheets("Stats")
   If dataWS Is Nothing Then GoTo Lexit
   Err.Clear

   'IF STATS SHEET DON'T EXIST => CREATE IT
   If statWs Is Nothing Then
      Set statWs = Worksheets.Add(, dataWS)
      If statWs Is Nothing Then MsgBox ("Can't create Stats Sheet"): GoTo Lexit
      statWs.Name = "Stats"
   End If

   'AFTER THIS POINT I DONT NEED RESUME NEXT
   Err.Clear
   On Error GoTo Lexit

   'GET DataTable
   Set datat = Worksheets("Data").ListObjects("DataTable")

   'POSITION IN STAT SHEET TO COPY THE TABLE => "A1"
   Set ar = statWs.Range("A1")
   
   'COPY THE TABLE AND NAME IT - CLEAR TABLE CONTENTS TO BE READY FOR COPY - IF NOT EXIST
   If ar.ListObject Is Nothing Then
      datat.Range.Copy ar
      ar.ListObject.Name = "StatTable"
   End If
   if Not ar.ListObject.DataBodyRange is Nothing Then
      ar.ListObject.DataBodyRange.Delete
   End If

   'MAKE A STRING WITH VALUES TO FIND, COUNT THEM
   filterdStr = char160
   For Each tar In vis
      For cc = 1 To tar.CountLarge
         If tar(cc) <> vbNullString Then
            filterdStr = filterdStr & tar(cc) & char160
            haveToFind = haveToFind + 1
         End If
      Next
   Next
   
   'SCAN LINE BY LINE THE TABLE AND IF TAKE -haveToFind- MATCHES THEN
   'ADD THE LINE NUMBER IN STRING
   arr() = datat.DataBodyRange
   ubr = UBound(arr, 1):   lbr = LBound(arr, 1)
   ubc = UBound(arr, 2):   lbc = LBound(arr, 2)
   For rr = lbr To ubr
      fcnt = 0
      For cc = lbc To ubc
         If arr(rr, cc) <> vbNullString Then
            If InStr(1, filterdStr, char160 & arr(rr, cc) & char160) > 0 Then fcnt = fcnt + 1
            If fcnt = haveToFind Then
               strRowsToCopy = strRowsToCopy & IIf(strRowsToCopy = vbNullString, "", " ") & rr
               GoTo LnextRow
            End If
         End If
      Next
LnextRow:
   Next

   'IF HAVE LINES TO COPY
   If strRowsToCopy <> vbNullString Then
      'SPLIT TO TAKE THE LINE NUMBERS
      ln = Split(strRowsToCopy)
      fcnt = 1
      'COPY THE LINES FROM SOURCE TABLE TO DESTINATION
      ubr = UBound(ln)
      For cc = LBound(ln) To ubr
         rr = Val(ln(cc))
         ar.ListObject.ListRows.Add
         datat.ListRows(rr).Range.Copy ar.ListObject.ListRows(fcnt).Range
         fcnt = fcnt + 1
      Next
   End If
Lexit:
   If Err.Number > 0 Then
      MsgBox ("doTheCopy>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)
   End If
   On Error GoTo 0
End Sub

Private Sub BT_FILTER_ITEMS_Click()
   Call doTheCopy
End Sub

第二个版本与精确搜索

Option Explicit

Private Sub doTheCopy(exact As Boolean)
   Dim datat As ListObject, vis As Range, ar As Range, tar As Range
   Dim statWs As Worksheet, dataWS As Worksheet
   Dim lbr As Long, ubr As Long, lbc As Long, ubc As Long, rr As Long, cc As Long, fcnt As Integer, haveToFind As Integer
   Dim arr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
   Const char160 = " "
   
   'FIND THE VISIBLE AREA
   Set vis = Me.ListObjects("ItemsTable").DataBodyRange.SpecialCells(xlCellTypeVisible)
   If vis Is Nothing Then Exit Sub
   
   'GET THE TWO OTHER SHEETS
   On Error Resume Next
   Set dataWS = Worksheets("Data")
   Set statWs = Worksheets("Stats")
   If dataWS Is Nothing Then GoTo Lexit
   Err.Clear

   'IF STATS SHEET DON'T EXIST => CREATE IT
   If statWs Is Nothing Then
      Set statWs = Worksheets.Add(, dataWS)
      If statWs Is Nothing Then MsgBox ("Can't create Stats Sheet"): GoTo Lexit
      statWs.Name = "Stats"
   End If

   'AFTER THIS POINT I DONT NEED RESUME NEXT
   Err.Clear
   On Error GoTo Lexit

   'GET DataTable
   Set datat = Worksheets("Data").ListObjects("DataTable")

   'POSITION IN STAT SHEET TO COPY THE TABLE => "A1"
   Set ar = statWs.Range("A1")
   
   'COPY THE TABLE AND NAME IT - CLEAR TABLE CONTENTS TO BE READY FOR COPY - IF NOT EXIST
   If ar.ListObject Is Nothing Then
      datat.Range.Copy ar
      ar.ListObject.Name = "StatTable"
   End If
   ar.ListObject.DataBodyRange.Delete

   'MAKE A STRING WITH VALUES TO FIND, COUNT THEM
   filterdStr = char160
   For Each tar In vis
      For cc = 1 To tar.CountLarge
         If tar(cc) <> vbNullString Then
            filterdStr = filterdStr & tar(cc) & char160
            haveToFind = haveToFind + 1
         End If
      Next
   Next
   
   'SCAN LINE BY LINE THE TABLE AND IF TAKE -haveToFind- MATCHES THEN
   'ADD THE LINE NUMBER IN STRING
   arr() = datat.DataBodyRange
   ubr = UBound(arr, 1):   lbr = LBound(arr, 1)
   ubc = UBound(arr, 2):   lbc = LBound(arr, 2)
   For rr = lbr To ubr
      fcnt = 0
      For cc = lbc To ubc
         If arr(rr, cc) <> vbNullString Then
            If InStr(1, filterdStr, char160 & arr(rr, cc) & char160) > 0 Then
               fcnt = fcnt + 1
            Else
               If exact Then GoTo LnextRow
            End If
            If fcnt = haveToFind Then
               strRowsToCopy = strRowsToCopy & IIf(strRowsToCopy = vbNullString, "", " ") & rr
               GoTo LnextRow
            End If
         End If
      Next
LnextRow:
   Next

   'IF HAVE LINES TO COPY
   If strRowsToCopy <> vbNullString Then
      'SPLIT TO TAKE THE LINE NUMBERS
      ln = Split(strRowsToCopy)
      fcnt = 1
      'COPY THE LINES FROM SOURCE TABLE TO DESTINATION
      ubr = UBound(ln)
      For cc = LBound(ln) To ubr
         rr = Val(ln(cc))
         If ar.ListObject.ListRows.Count < fcnt Then
            ar.ListObject.ListRows.Add
         End If
         datat.ListRows(rr).Range.Copy ar.ListObject.ListRows(fcnt).Range
         fcnt = fcnt + 1
      Next
   End If
Lexit:
   If Err.Number > 0 Then
      MsgBox ("doTheCopy>" & vbCrLf & Err.Description & vbCrLf & "error number> " & Err.Number)
   End If
   On Error GoTo 0
End Sub

Private Sub BT_FILTER_ITEMS_Click()
   Call doTheCopy(Me.ExactSearch.value)
End Sub