■文章データの抽出

#ボツ回答シリーズ :)

Sheet1.A列に文章データが9000。抽出元。
Sheet2.A列に単語データが500。検索条件。
文章の中に単語が１つでも含まれていればSheet3.A列に抽出。

処理時間にあまり拘らないなら、AdvancedFilterメソッドを使う手法がある。
（[データ]-[フィルタ]-[フィルタオプションの設定]）
事前準備として、
１）抽出元文章データのSheet1.A1セルの「項目名」と
　　検索条件単語のSheet2.A1セルの「項目名」を同じにする必要あり。
２）検索条件単語の頭にワイルドカード『*』を付けておく。
マクロは１行。
Sheets("Sheet1").Range("A1:A9000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet2").Range("A1:A500"), CopyToRange:=Sheets("Sheet3").Range("A1"), Unique:=True

#データによっては激遅か..
#配列処理するなら文字数制限を考慮しないといけない？

元お題でのInStr関数を使った例。

Option Explicit
Sub test()
　　Dim col As Collection
　　Dim s() As String
　　Dim i　 As Long
　　Dim v, vi, w, wi, c

　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With

　　With Sheets("Sheet1")
　　　　v = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value
　　End With
　　With Sheets("Sheet2")
　　　　w = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value
　　End With

　　ReDim s(1 To UBound(v), 0)
　　Set col = New Collection

　　For Each vi In v
　　　　For Each wi In w
　　　　　　If InStr(vi, wi) > 0 Then
　　　　　　　　i = i + 1
　　　　　　　　If Len(vi) < 912 Then
　　　　　　　　　　s(i, 0) = vi
　　　　　　　　Else
　　　　　　　　　　col.Add VBA.Array(i, vi)
　　　　　　　　End If
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　Next

　　If i > 0 Then
　　　　With Sheets("Sheet3").Columns("A")
　　　　　　.ClearContents
　　　　　　.Resize(i).Value = s
　　　　　　For Each c In col
　　　　　　　　.Cells(c(0), 1).Value = c(1)
　　　　　　Next
　　　　End With
　　End If

　　Set col = Nothing
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
End Sub