根据单元格值自动过滤

Question

我想根据单元格值做一个自动过滤器，我的代码大部分都可以工作，但我仍然坚持两件事

1. 我希望它是部分匹配（目前是完全匹配）
2. 我希望它不区分大小写（目前它区分大小写） 如何修改代码？

代码中的 Q2 是指列标题，Q3 是指实际值（名称） 预先感谢您的帮助！

    Sub Filter()
    Dim FNameVal As String
    Dim cell As Range

    With Sheets("Database")
        FNameVal = .Range("Q3").Value2
        For Each cell In .Range("B6:U1000").Cells
            If FNameVal = cell.Value2 Then
                Range("B6:U1000").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("Q2:Q3")
                Exit For
            End If
        Next
    End With
    
End Sub

Answer 1

过滤范围

Option Explicit

Sub filterRange()
    With ThisWorkbook.Worksheets("Database")
        Dim cel As Range: Set cel = .Range("B6")
        Dim rg As Range
        With cel.CurrentRegion
            Set rg = cel.Resize(.Row + .Rows.Count - cel.Row, _
                .Column + .Columns.Count - cel.Column)
        End With
        'Debug.Print rg.Address
        Dim Header As String: Header = CStr(.Range("Q2").Value)
        Dim cIndex As Variant
        cIndex = Application.Match(Header, rg.Rows(1), 0)
        If IsNumeric(cIndex) Then
            Application.ScreenUpdating = False
            .AutoFilterMode = False
            Dim Criteria As String
            Criteria = "*" & CStr(.Range("Q3").Value) & "*"
            rg.AutoFilter cIndex, Criteria
            Application.ScreenUpdating = True
        Else
            MsgBox "The range '" & rg.Address(0, 0) & "' does not contain " _
                & "the header '" & Header & "'.", vbExclamation, _
                "Header Not Found"
        End If
    End With
End Sub