使用多个变量的 VBA 循环工作表过滤器

Question

我正在尝试为我的一些员工提供一个简单的搜索选项卡，以便他们轻松过滤大型数据表中的特定条目，然后将主列表中的行复制到搜索选项卡中。

下面的代码确实有效，并从匹配的条目中复制数据，不幸的是，“国家”是唯一有效的标准，其余的什么都不做。

我要做的是调整我编写的代码以使所有条件都能正常工作，如果相应搜索中的条件为空白，那么它会忽略该条件，允许复制和粘贴该单元格中的任何值。我正在考虑为所有条件添加 If Else 语句可以完成这项工作，但我不确定如何在 VBA 中为所有字符串正确添加 If Else 语句，并告诉它如果为空白则忽略条件。

Sub search_and_extract_multicriteria()

Dim datasheet As Worksheet 'where is the data copied from
Dim reportsheet As Worksheet 'where is the data pasted to
Dim country As String
Dim SubType As String
Dim ProductName As String
Dim ProductFormula As String
Dim Source As String
Dim Rating As String
Dim finalrow As Integer
Dim i As Integer 'row counter

Set datasheet = Sheet1
Set reportsheet = Sheet3
country = reportsheet.Range("A3").Value
SubType = reportsheet.Range("C3").Value
ProductName = reportsheet.Range("D3").Value
ProductFormula = reportsheet.Range("E3").Value
Source = reportsheet.Range("F3").Value
Rating = reportsheet.Range("G3").Value

reportsheet.Range("A16:K500").ClearContents 

datasheet.Select
'finalrow = Cells(Row.Count, 1).End(x1Up).Row

For i = 2 To 500 'finalrow
    If Cells(i, 1) = country And Cells(i, 3) = SubType And Cells(i, 4) = ProductName And Cells(i, 5) = ProductFormula And Cells(i, 6) = Source And Cells(i, 2) = TestimonialType And Cells(i, 9) = Rating Then 
        Range(Cells(i, 1), Cells(i, 11)).Copy 'copy columns 1 to 11 (A to K)
        reportsheet.Select 
        Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats 
        datasheet.Select 
        End If
Next i

reportsheet.Select 'this is so that the report sheet is selected when the procedure ends

End Sub

Answer 1

与其使用循环，不如在检查变量是否填充了实际值后使用内置的AutoFilter 方法。

With datasheet.Range(.Range("A1"), .Cells(500, 11))

    If Len(country) Then .AutoFilter 1, country
    If Len(TestimonialType) Then .AutoFilter 2, TestimonialType
    If Len(SubType) Then .AutoFilter 3, SubType
    If Len(ProductName) Then .AutoFilter 4, ProductName
    If Len(ProductFormula) Then .AutoFilter 5, ProductFormula
    If Len(Source) Then .AutoFilter 6, Source
    If Len(Rating) Then .AutoFilter 9, Rating

    .Offset(1).SpecialCells(xlCellTypeVisible).Copy 'offset 1 to remove header row
    reportsheet.Range("A200").End(xlUp).Offset(1).PasteSpecial xlPasteValuesAndNumberFormats

    .AutoFilter 'reset filter

End With