过滤问题

Posted 2020-10-24 Excel VBA 小天地

Sub FiterQuestion()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim dHow As Object
    Dim dWhat As Object
    Dim HasHow As Boolean
    Dim HasWhat As Boolean
    Dim Dic As Object
    Dim Index As Long
    Dim Ar() As String
    ReDim Ar(1 To 3, 1 To 1)
    Set Dic = CreateObject("Scripting.Dictionary")
    Set dHow = CreateObject("Scripting.Dictionary")
    Set dWhat = CreateObject("Scripting.Dictionary")
    
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("Filter")
    With Sht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        For i = 2 To endrow
            Key = .Cells(i, 1).Text
            dHow(Key) = ""
        Next i
        endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
        For i = 2 To endrow
            Key = .Cells(i, 2).Text
            dWhat(Key) = ""
        Next i
    End With
    
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("Question")
    With Sht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A2:C" & endrow)
        Arr = Rng.Value
        Index = 0
        For i = LBound(Arr) To UBound(Arr)
            HasHow = False
            HasWhat = False
            Ques = CStr(Arr(i, 3))
            For Each OneHow In dHow.Keys
                If InStr(Ques, OneHow) > 0 Then
                    HasHow = True
                    Exit For
                End If
            Next OneHow
            
            For Each OneWhat In dWhat.Keys
                If InStr(Right(Ques, 6), OneWhat) > 0 Then
                    HasWhat = True
                    Exit For
                End If
            Next OneWhat
            
            If HasHow And HasWhat Then
                Index = Index + 1
                ReDim Preserve Ar(1 To 3, 1 To Index)
                For j = 1 To 3
                  Ar(j, Index) = Arr(i, j)
                Next j
            End If
            
        Next i
        
    End With
    
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("After")
    With Sht
.UsedRange.Offset(1, 0).ClearContents
       
        Set Rng = .Range("A2")
        Set Rng = Rng.Resize(Index, 3)
Rng.Value = Application.WorksheetFunction.Transpose(Ar)
        
    End With
    
    
    Set Dic = Nothing
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    Set dWhat = Nothing
    Set dHow = Nothing
    
    
End Sub