使用特定值过滤数据表

Question

我有一个包含两张表的 Excel 工作簿。

名为“Items”的工作表包含一个名为“ItemsTable”的单列表，其中包含多个条目。多少都没关系。
我在旁边添加了一个“过滤”按钮以供以后使用：

其次，我有一个名为“Data”的工作表，其中有一个名为“DataTable”的表。在此表中，我随机添加了 ItemsTable 中的条目（每个单元格都是一个下拉列表，我可以在其中从 ItemsTable 中选择一个条目）。可以有空白单元格。

到目前为止可用的数据。我想从这里提取一些数据。
首先，我手动过滤“项目”表上的一些项目，例如这次仅过滤梨和香蕉：

当我单击“过滤器”按钮时，它应该获取选定的项目（本例中为两个）并检查这些项目是否同时出现在数据表的行上。
它们（或者无论我选择多少项）都必须以任何顺序排成一行。
其想法是创建一个名为“Stats”的新工作表（如果该工作表已存在，则删除内容），并在该工作表上创建一个与“DataTable”表具有相同标题的表，并添加符合该条件的所有行新创建的表。

因此，在这种情况下，将创建“统计”表（或清除内容（如果存在）），并且应添加一个包含以下行的表格：

我想要此过滤器按钮的 VBA 代码：

Sub Filter()

End Sub

我尝试使用数组和循环，但每次都会遇到几个问题。
我在尝试仅使用使用

SpecialCells(xlCellTypeVisible)

过滤的选定项目时遇到了问题。
我不会粘贴我尝试过的代码，因为它可能毫无用处。

Answer 1

检索过滤后的数据

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

Answer 2

一步步在一个子程序中

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

'*****************PARAMETERS**************************************
' exact> for exact search (true) else (false)
' copyAtCell> the position (a cell) in any sheet to create the stat table
' Optional lookHeadersStartWith> look at columns whose headings
'          begin with "Item" (default) or any other string.
'          The comparison is case insensitive (in the comparison spaces are cut off)
'*****************************************************************
Private Sub doTheCopy(exact As Boolean, copyAtCell As Range, Optional lookHeadersStartWith As String = "ITEM")
   Dim datat As ListObject, vis As Range, tar As Range
   Dim statWs As Worksheet, dataWS As Worksheet, statTbl As ListObject, lr As ListRow
   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, hdr() As Variant, ln() As String, filterdStr As String, strRowsToCopy As String
   Const char160 = " "
   
   If copyAtCell.CountLarge > 1 Then Set copyAtCell = copyAtCell.Cells(1, 1)
   '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 create stats table => copyAtCell
   'if in position (copyAtCell) exist any table delete it
   If Not copyAtCell.ListObject Is Nothing Then
      copyAtCell.ListObject.Delete
   End If
   
   'create new table at position (copyAtCell) with equal number of columns
   Set statTbl = copyAtCell.Worksheet.ListObjects.Add(xlSrcRange, copyAtCell.Resize(1, datat.DataBodyRange.Columns.Count), , xlYes)
   'can now give it a name for further reference
   statTbl.Name = "STAT_TABLE"
   'copy headers from DataTable
   datat.HeaderRowRange.Copy copyAtCell

   '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
   hdr() = datat.HeaderRowRange
   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 And InStr(1, UCase(Trim(hdr(1, cc))), lookHeadersStartWith) = 1 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 And exact = False Then
               GoTo LfoundOneRow
            End If
         End If
      Next
      If exact = True And fcnt >= haveToFind Then
LfoundOneRow:
         strRowsToCopy = strRowsToCopy & IIf(strRowsToCopy = vbNullString, "", " ") & rr
      End If
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 statTbl.ListRows.Count < fcnt Then
          Set lr = statTbl.ListRows.Add
         'End If
         datat.ListRows(rr).Range.Copy lr.Range       'statTbl.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, Worksheets("Stats").Range("A1"))
End Sub