関数は自分で作る

次図は、再帰呼び出しの説明用です。再帰呼び出しとは、プロシージャの中で自分自身のプロシージャを呼び出すことです。作った関数はVBAの機能だけで使える。

次図のディスクトップのabcフォルダ以下の検索を例に説明する。

以下の内容のファイルをディスクトップに作って下さい。ファイル名はmakeabc.batです。このファイルをダブルクリックするとディスクトップ上にmakeabc.batがあればディスクトップ下に同じフォルダができます。

mkdir abc
copy makeabc.bat abc\a.txt
copy makeabc.bat abc\b.txt
mkdir abc\456
copy makeabc.bat abc\456\a.txt
copy makeabc.bat abc\456\b.txt
mkdir abc\123
copy makeabc.bat abc\123\a.txt
mkdir abc\123\aaa
copy makeabc.bat abc\123\aaa\aa.txt
copy makeabc.bat abc\123\aaa\bb.txt

以降は、作成した関数（Functionプロシージャ）の説明。

ディレクトリ構造を再帰呼び出しで処理するには、再帰呼び出し前の処理とその後の処理に分けて考える。

1. 前半：再帰呼び出しの対象はフォルダ。プロシージャの引数のフォルダ下 （直下のフォルダだけ） の全フォルダを調べ。直下のフォルダだけ に対して再帰呼び出しする。①と②
2. 後半：プロシージャの値を改行コードをはさんで作る。直下のファイルだけを処理する。目的の処理。③

再帰呼び出しは、呼び出し時に一時的に積まれる変数、プロシージャの引数やプロシージャ内の変数はすべて呼び出しの度に個別にスタックに積まれる。呼び出し時に積まれるスタックを意識できるのは次図のエラーだろう。

スタックの存在は、次のコードを実行すると「スタックオーバー」のエラーになるのでスタックの存在がわかる。

Sub main()
  a 1, 2
End Sub

Sub a(引数1 As Integer, 引数2 As Long)
  Dim ii As Long 'ローカル変数。aプロシージャ内で有効な変数。プロシージャレベルの変数
  引数1  = ii + 1
  a 引数1, 引数2 + 1  '自分自身を呼び出す。再帰呼び出しでスタックにデータをその都度積む
End Sub

注意！作成中のExcelやWordが飛ぶことがあります。私の環境Office32ビット、Windows10は64ビットでは２度以上実行すると飛びました。Excel本体が動くメモリ領域の下のアドレスからアドレス番地をアップしていきます。Excel本体のメモリまで突入？。会社のPCでも32ビットのOfficeですが問題ありません。私のPCが例外です。

再帰呼び出し/リカーシブルコールは、以下の２つの図の考えが必要です。

引数は、呼び出し側から渡された変数。プロシージャー内でDim宣言した変数は内部で使える一時的な変数。これらは、再帰呼び出し毎に違う。再帰呼び出しのプロシージャーを書くときは各処理で引数に応じて処理が完結できるように書く。でも、プロシージャー名が同じで引数は違うって言ってもなかなかね。上図をもう一度見て下さい。フォルダごとに引数が違います！！。

今回使った関数のコードです。

'vba.dirで再帰処理
Function myAllFileFolder(sPath As String, sWildCard As String) As String
   On Error GoTo myErr '使用中や権限のなのﾌｧｲﾙを扱ったときは、無視させる
   Dim r As String, col As New VBA.Collection
   If VBA.Right(sPath, 1) <> "\" Then sPath = sPath & "\" 'sPath最後が\で無い場合\を付ける
'あるフォルダ内の全フォルダを検索して、colに登録
   r = VBA.Dir(sPath & "*.*", vbDirectory) 'vbDirectoryでもファイルを含むので以後でGetAttrで分別
   Do Until r = ""
      If r <> "." And r <> ".." Then '無視。"."は自分のﾃﾞｨﾚｸﾄﾘ。".."は親ﾃﾞｨﾚｸﾄﾘ
        If VBA.GetAttr(sPath & r) = VBA.vbDirectory Then   'フォルダ/ﾃﾞｨﾚｸﾄﾘの場合だけ
            col.Add r
        End If
      End If
      r = VBA.Dir
      DoEvents '長い場合に中断できるようにWindowsからのメッセージを受け付ける
   Loop
'ﾃﾞｨﾚｸﾄﾘの場合は、再帰呼び出し
   Dim x
   For Each x In col
            myAllFileFolder = myAllFileFolder & myAllFileFolder(sPath & x, sWildCard) '再帰呼び出し
   Next
'sWildCardで指定したﾌｧｲﾙだけを検索。検索対象はsPathﾌｫﾙﾀﾞ内だけ
   r = VBA.Dir(sPath & sWildCard, vbArchive + vbHidden + vbNormal + vbReadOnly + vbSystem) '全ファイルが検索対象
   Do Until r = ""   '""は、もう該当のﾌｧｲﾙがないことを意味する
      If r <> "." And r <> ".." Then '無視。"."は自分のﾃﾞｨﾚｸﾄﾘ。".."は親ﾃﾞｨﾚｸﾄﾘ
         myAllFileFolder = myAllFileFolder & sPath & r & VBA.vbCrLf '改行ｺｰﾄﾞを挟んで検索されたﾌｧｲﾙ名を保存
      End If
      r = VBA.Dir '繰り返し
      DoEvents '長い場合に中断できるようにWindowsからのメッセージを受け付ける
   Loop
   Exit Function
myErr: '多くのエラーは権限の問題
   Debug.Print Err.Number, Err.Description
   Debug.Print sPath, r
'   Stop 'エラーが多い場合の確認用
   Resume Next '状況を出力したら、やりなおしはResume。もし、そのエラーを無視して次へ行く場合はResume Nextに
End Function
'?myAllFileFolder(VBA.Environ("userprofile")  & "\desktop\abc", "*.*")
'?myAllFileFolder("c:\windows\system32\drivers","*.*")

がおすすめです。

とゆうのは、マクロは繰り返し処理で本領を発揮します。特定のセル番地がだと編集が手間です。よって、「相対参照で記録」ボタンは必ず押しましょう。

絶対的なセル「A1」のようなセルの位置を記録するより、相対的に「今のセルの１つ下のセル」とか「今のセルの右２つ先のセル」と記録した方がプログラムでは利用しやすい。「相対参照で記録」にすると、RangeオブジェクトのOffsetプロパティが使わる。

“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 'あるフォルダの全ファイルを一つずつｘに入れる
        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 'あるフォルダの全ファイルを一つずつｘに入れる
        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) 'ｒはフルパスのセルを指定
    Dim ar
    ar = VBA.Split(r, "\")
    myGetFile = ar(UBound(ar))
End Function

Function myGetPath(r As Range) 'ｒはフルパスのセルを指定
    Dim x
    x = myGetFile(r)
    myGetPath = VBA.Replace(r.Value, x, "")
End Function