■Dir再帰|非再帰

対象フォルダ配下サブフォルダ含めてファイルリストを取得したい、というニーズであまり使われないDir関数。
不具合あるからね。でもあまのじゃっきーだから一応書いてみる。

Option Explicit

Private Const cPath As String = "C:¥WORK¥" '対象フォルダパス
Private Const MX　　As Long = 100000　　　 '取得用配列サイズ大きめに
Private fList()　　 As String　　　　　　　'ファイル名取得用配列
Private idx　　　　 As Long　　　　　　　　'配列Index
'-------------------------------------------------
Private Sub test() 'テストプロシージャ選択用
　　Dim t As Single
　　t = Timer

　　Call TestDirRecur

　　Debug.Print idx & " files", Timer - t
End Sub
'-------------------------------------------------
Private Sub TestDirRecur() '再帰版
　　Dim sPath As String
　　ReDim fList(1 To MX, 0)

　　sPath = cPath
　　idx = 0
　　Call DirRecur(sPath)
　　'Sheets.Add.Range("A1").Resize(idx).Value = fList
　　Erase fList
End Sub
Private Sub DirRecur(sPath As String)
　　Dim sList(1 To 1000) As String
　　Dim fPath As String
　　Dim ret　 As String
　　Dim si　　As Long
　　Dim i　　 As Long

　　On Error GoTo ErrH:
　　ret = Dir(sPath, vbDirectory Or vbReadOnly _
　　　　　　　　　　 Or vbHidden Or vbSystem)
　　Do Until Len(ret) = 0
　　　　If ret <> "." And ret <> ".." Then
　　　　　　idx = idx + 1
　　　　　　fPath = sPath & ret
　　　　　　fList(idx, 0) = fPath
　　　　　　If GetAttr(fPath) And vbDirectory Then
　　　　　　　　si = si + 1
　　　　　　　　sList(si) = fPath & "¥"
　　　　　　End If
　　　　End If
　　　　ret = Dir()
　　Loop

　　For i = 1 To si
　　　　Call DirRecur(sList(i))
　　Next

　　Exit Sub

ErrH:
　　'Debug.Print fPath
　　'Debug.Print Err.Number, Err.Description
　　Resume Next
End Sub
'-------------------------------------------------
Private Sub TestDirLoop()　'非再帰版
　　Dim sPath As String
　　Dim fPath As String
　　Dim ret　 As String
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim d(1 To MX) As Long 'サブフォルダidx記憶用
　　ReDim fList(1 To MX, 0)

　　On Error GoTo ErrH:
　　sPath = cPath
　　idx = 0
　　Do
　　　　ret = Dir(sPath, vbDirectory Or vbReadOnly _
　　　　　　　　　　　　 Or vbHidden Or vbSystem)
　　　　Do Until Len(ret) = 0
　　　　　　If ret <> "." And ret <> ".." Then
　　　　　　　　idx = idx + 1
　　　　　　　　fPath = sPath & ret
　　　　　　　　fList(idx, 0) = fPath
　　　　　　　　If GetAttr(fPath) And vbDirectory Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　d(i) = idx
　　　　　　　　End If
　　　　　　End If
　　　　　　ret = Dir()
　　　　Loop

　　　　j = j + 1
　　　　If j > i Then Exit Do
　　　　sPath = fList(d(j), 0) & "¥"
　　Loop

　　'Sheets.Add.Range("A1").Resize(idx).Value = fList
　　Erase fList

　　Exit Sub

ErrH:
　　'Debug.Print fPath
　　'Debug.Print Err.Number, Err.Description
　　Resume Next
End Sub

結果。Unicode文字あるとGetAttr関数のところでエラーになるし、256Byteあたりの制限ありますよね..
なので実用的ではないけど..一応。

[TestDirRecur]
20000 files　　1.375
20000 files　　1.359375
20000 files　　1.359375

[TestDirLoop]
20000 files　　1.390625
20000 files　　1.359375
20000 files　　1.34375

C:\WORK配下のフォルダは最大10階層。
20,000ファイル＆フォルダでのテスト。
#つまり昨日と一緒.. :)

■Fso再帰|非再帰

#しばらくscrapネタ続きます.. :)

対象フォルダ配下サブフォルダ含めてファイルリストを取得したい、というニーズでよく使われるFileSystemObject再帰。
あまのじゃっきーな私はこの非再帰コードを書いてみた。

Option Explicit

Private Const cPath As String = "C:¥WORK¥" '対象フォルダパス
Private Const MX　　As Long = 100000　　　 '取得用配列サイズ大きめに
Private FSO　　　　 As Object　　　　　　　'FileSystemObject
Private fList()　　 As String　　　　　　　'ファイル名取得用配列
Private idx　　　　 As Long　　　　　　　　'配列Index
'-------------------------------------------------
Private Sub test() 'テストプロシージャ選択用
　　Dim t As Single
　　t = Timer

　　Call TestFsoLoop

　　Debug.Print idx & " files", Timer - t
End Sub
'-------------------------------------------------
Private Sub TestFsoRecur() '再帰版
　　Dim sPath As String
　　ReDim fList(1 To MX, 0)

　　sPath = cPath
　　idx = 0
　　Set FSO = CreateObject("scripting.filesystemobject")
　　Call FsoRecur(sPath)
　　Set FSO = Nothing
　　'Sheets.Add.Range("A1").Resize(idx).Value = fList
　　Erase fList
End Sub
Private Sub FsoRecur(sPath As String)
　　Dim x As Object

　　With FSO.GetFolder(sPath)
　　　　For Each x In .Files
　　　　　　idx = idx + 1
　　　　　　fList(idx, 0) = x.Path
　　　　Next
　　　　For Each x In .SubFolders
　　　　　　idx = idx + 1
　　　　　　fList(idx, 0) = x.Path
　　　　　　Call FsoRecur(x.Path)
　　　　Next
　　End With
End Sub
'-------------------------------------------------
Private Sub TestFsoLoop()　'非再帰版
　　Dim x　　 As Object
　　Dim sPath As String
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim d(1 To MX) As Long 'サブフォルダidx記憶用
　　ReDim fList(1 To MX, 0)

　　sPath = cPath
　　idx = 0
　　Set FSO = CreateObject("scripting.filesystemobject")
　　Do
　　　　With FSO.GetFolder(sPath)
　　　　　　For Each x In .SubFolders
　　　　　　　　idx = idx + 1
　　　　　　　　i = i + 1
　　　　　　　　fList(idx, 0) = x.Path
　　　　　　　　d(i) = idx
　　　　　　Next
　　　　　　For Each x In .Files
　　　　　　　　idx = idx + 1
　　　　　　　　fList(idx, 0) = x.Path
　　　　　　Next
　　　　End With
　　　　j = j + 1
　　　　If j > i Then Exit Do
　　　　sPath = fList(d(j), 0)
　　Loop
　　Set FSO = Nothing
　　'Sheets.Add.Range("A1").Resize(idx).Value = fList
　　Erase fList
End Sub

結果。別に速さを求めたわけじゃないけど..一応。

[TestFsoRecur]
20000 files　　15.70313
20000 files　　15.71875
20000 files　　15.71875

[TestFsoLoop]
20000 files　　15.03125
20000 files　　15.03125
20000 files　　15.03125

C:\WORK配下のフォルダは最大10階層。
20,000ファイル＆フォルダでのテスト。

■Shell "cmd.exe /c md ""[drive:]path""" とか

#ボツ回答シリーズ :)
#ぃゃ、本筋と関係ないし多分混乱するだろうから自粛..

Sub try()
　　Const CMD = "cmd.exe /c md """
　　Const FL1 = "最下層1"
　　Const FL2 = "最下層2"
　　Dim FL As String
　　Dim p　As String

　　p = Application.PathSeparator
　　FL = Join(Array(ThisWorkbook.Path, "TESTフォルダ", "SUBフォルダ", Format$(Date, "yymmdd")), p) & p
　　MsgBox FL
　　Shell CMD & FL & FL1 & """"
　　Shell CMD & FL & FL2 & """"
End Sub

Shell関数でDOSコマンドMKDIR(MD)使って多階層フォルダを一気に作成..
というのもありかも。

■文章データの抽出

#ボツ回答シリーズ :)

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

■New DataObject

#ボツ回答シリーズ :)

DataObjectって意外と便利。と思ってたりする。
「ActiveSheetのA:T列の空白セル以外のデータをヨコ方向優先順でタテ1列に並べ直したい」ニーズがあったとして..

Sub test()
　　Dim reg As Object
　　Dim s　 As String

　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Global = True
　　reg.Pattern = "¥t+"
　　With ActiveSheet
　　　　Intersect(.UsedRange, .Columns("A:T")).Copy
　　End With
　　With GetObject("new:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
　　　　.GetFromClipboard
　　　　s = .GetText
　　　　.Clear
　　　　.SetText reg.Replace(s, vbLf)
　　　　.PutInClipboard
　　End With
　　With Sheets.Add
　　　　.Paste .Range("A1")
　　End With
　　Set reg = Nothing
End Sub