“Scripting.FileSystemObject”を使うのが簡単です。
作ったユーザー定義関数の引数は、fileSearch(パス名,ファイルのワイルドカード)。パス名の下の全ワイルドカードのファイルをVBA.vbCrLfを挟んで文字列にする。
Function fileSearch(sPath As String, sWildCard As String) As String
On Error GoTo myErr 'エラートラップ
Dim fso, x
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
For Each x In fso.GetFolder(sPath).SubFolders 'サブフォルダまで検索できる
fileSearch = fileSearch & fileSearch(x.Path, sWildCard) '再帰呼び出し
Next
For Each x In fso.GetFolder(sPath).Files 'あるフォルダの全ファイルを一つずつxに入れる
If x.Name Like sWildCard Then 'Likeはパターン一致の演算子。=も演算子
fileSearch = fileSearch & x.Path & VBA.vbCrLf
' Debug.Print File.Path
End If
Next
DoEvents '長い場合に中断できるようにWindowsからのメッセージを受け付ける
Exit Function
myErr:
Debug.Print Err.Number, Err.Description
' Stop 'エラーが多い場合の確認用
Resume Next '状況を出力したら、やりなおしはResume。もし、そのエラーを無視して次へ行く場合はResume Nextに
End Function
'?fileSearch(VBA.Environ("homedrive") & VBA.Environ("homepath") & "\desktop", "*.*")
上のコードの最後の行、コメントアウトしている行をイミディエイトウィンドウに貼り付けると実行できます。
Excelに標準モジュールを追加して、以下を貼り付けtestを実行して下さい。
Option Explicit
'CreateObject("Scripting.FileSystemObject")で再帰処理
Function fileSearch(sPath As String, sWildCard As String) As String
On Error GoTo myErr 'エラートラップ
Dim fso, x
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
For Each x In fso.GetFolder(sPath).SubFolders 'サブフォルダまで検索できる
fileSearch = fileSearch & fileSearch(x.Path, sWildCard) '再帰呼出/リカーシブルコール.上と下の処理
Next
For Each x In fso.GetFolder(sPath).Files 'あるフォルダの全ファイルを一つずつxに入れる
If x.Name Like sWildCard Then 'Likeはパターン一致の演算子。=も演算子
fileSearch = fileSearch & x.Path & VBA.vbCrLf
' Debug.Print File.Path
End If
Next
VBA.DoEvents '長い場合に中断できるようにWindowsからのメッセージを受け付ける
Exit Function
myErr: 'ラベル
Debug.Print Err.Number, Err.Description
' Stop 'エラーが多い場合の確認用
Resume Next '状況を出力したら、やりなおしはResume。もし、そのエラーを無視して次へ行く場合はResume Nextに
End Function
'?fileSearch(VBA.Environ("homedrive") & VBA.Environ("homepath") & "\desktop", "*.*")
Sub test()
Dim ss As String
Dim pa As String, fi As String
pa = VBA.Environ("homedrive") & VBA.Environ("homepath") & "\desktop"
fi = "*.*"
' ss = myAllFileFolder(pa, fi)
ss = fileSearch(pa, fi)
Application.Range("a1").Select
copyExcel ss
End Sub
Sub copyExcel(str As String)
Dim tmp, i As Integer
tmp = VBA.Split(str, VBA.vbCrLf)
For i = 0 To UBound(tmp)
ActiveCell.Offset(i, 0).Value = tmp(i)
Next
End Sub
Function myGetFile(r As Range) 'rはフルパスのセルを指定
Dim ar
ar = VBA.Split(r, "\")
myGetFile = ar(UBound(ar))
End Function
Function myGetPath(r As Range) 'rはフルパスのセルを指定
Dim x
x = myGetFile(r)
myGetPath = VBA.Replace(r.Value, x, "")
End Function
(Visited 149 times, 1 visits today)