创建小专题

Sub PartFiterQuestion()

Application.DisplayAlerts = False

    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("创建小专题")
    With Sht
        PartName = .Range("C2").Text
        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
    
On Error Resume Next
      Wb.Worksheets(PartName).Delete
On Error GoTo 0

    
    
  
    Set NewSht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
    NewSht.Name = PartName
    
    'Set NewSht = Wb.Worksheets("PartAfter")
    With NewSht
        .Range("A1:C1").Value = Array("试卷", "URL", "问题")
        
        Set Rng = .Range("A2")
        Set Rng = Rng.Resize(Index, 3)
        Rng.Value = Application.WorksheetFunction.Transpose(Ar)
        .UsedRange.Columns.AutoFit
        
    End With
    
    
    Set Dic = Nothing
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing
    Set dWhat = Nothing
    Set dHow = Nothing
    
Application.ScreenUpdating = True
    
End Sub