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