あるフォルダの下全部FileSystemObject

“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)
カテゴリー: 13 ファイル処理、メモ帳とのデータ処理 パーマリンク

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です