vba - Table.Autofilter 使用部分 cells.value

Question

我想仅使用这些地址的域来过滤包含电子邮件地址的表/范围。这些电子邮件地址的域是使用列表框“列表框 9”选择的。如果我从此列表框中选择了 1 或 2 个项目，我的代码可以工作，但如果有 3 个或更多，它就不起作用。

我怀疑这是用于搜索的“*”的情况，但我不知道如何解决它。

Dim wb, wbR As Workbook
Dim Sht, RSht As Worksheet
Dim ListU As ListBox
Dim i As Long
Dim totalSelected  As Long
Dim selectedItems As Variant
Dim selectedCounter As Long
Dim lastRow As Long
Dim Rng As Excel.Range


Application.ScreenUpdating = False

Set wb = ThisWorkbook
Set Sht = wb.Worksheets(1)


Set ListU = Sht.ListBoxes("List Box 9") ' has the same information as Rng
lastRow = WorksheetFunction.CountA(wb.Sheets(4).Columns("F:F"))
Set Rng = Range(wb.Sheets(4).Cells(2, 5), wb.Sheets(4).Cells(lastRow, 5)) ' the column with email domains eg. "@dom.com"

'find selected items in a list box
For i = 1 To ListU.ListCount
    If ListU.Selected(i) Then
        
        totalSelected = totalSelected + 1
    End If
Next i


' Add the selected items to an array

ReDim selectedItems(totalSelected - 1)
For i = 1 To ListU.ListCount
    If ListU.Selected(i) Then
        
        selectedItems(selectedCounter) = "*" & ListU.List(i) ' I will use this in a table with the full email address eg. "[e-mail]"
        selectedCounter = selectedCounter + 1
    End If
Next i


Set wbR = Workbooks.Open(Filename:="C:\Users\user.name\Desktop\address.xlsx", ReadOnly:=True)

Set RSht = wbR.Worksheets(1)


' Filter the table using the array of selected items
RSht.Range("A:G").AutoFilter Field:=7, Criteria1:=selectedItems, Operator:=xlFilterValues

标签： vbafilterexcel-formulalistbox

Answer 1

我找不到这种情况的解决方案，所以我做了一个循环。

Dim wb As Workbook
Dim Sht As Worksheet
Dim ListaUI As ListBox
Dim i As Long
Dim totalSelected, totalSelected2  As Long
Dim selectedItems, selectedItems2 As Variant
Dim selectedCounter, selectedCounter2 As Long
Dim wbR As Workbook
Dim RSht As Worksheet
Dim DL As Double

Application.ScreenUpdating = False

Set wb = ThisWorkbook
Set Sht = wb.Worksheets(1)
Set ListaUI = Sht.ListBoxes("List Box 9")
Set RSht = wbR.Worksheets(1)
Set wbR = Workbooks.Open(Filename:="C:\Users\user.name\Desktop\address.xlsx", ReadOnly:=True)


For i = 1 To ListaUI.ListCount
    If ListaUI.Selected(i) Then
        
        totalSelected = totalSelected + 1
    End If
Next i


' Add the selected items to an array
ReDim selectedItems(totalSelected - 1)
For i = 1 To ListaUI.ListCount
    If ListaUI.Selected(i) Then
        
        selectedItems(selectedCounter) = ListaUI.List(i)
        selectedCounter = selectedCounter + 1
    End If
Next i


'add selected to the filter
ReDim selectedItems2(selectedCounter - 1)
For i = 2 To lastRow

    
        DL = InStr(wb.Sheets(4).Cells(i, 5), ".") - 1
        selectedItems2(selectedCounter2) = "*" & Left(Rng.Item(i - 1), DL) & "*" ' in this way I have the part of the email address, the one before the dot
        RSht.Range("A:G").AutoFilter Field:=7, Criteria1:=selectedItems2, Operator:=xlFilterValues
        RSht.Range(Range("G3"), Range("G3").End(xlDown)).Copy
        With wb.Sheets(2)
        If .Range("G1").Value = "" Then
            .Range("G1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=True, Transpose:=False
      
        End With
        End If
    
Next i