指定パス直下のフォルダ名を取得したい

職場で受けた質問から、以下をたびたび取得する必要に迫られた。

指定パス直下のフォルダ名を全部

例えば ↓ C:\Tempであれば、

以下の全てが対象となる。

1. 2016
2. 2017
3. 2018

そこで、簡単に取得するマクロを作成することにした。
今回の作戦は、こうだ。

1. 「引数：フォルダパス、戻り値：配列」の関数とする。
2. サブフォルダの取得には、FileSystemObjectを使用する。
3. 一旦コレクションにため込み、いつものToArray関数で変換する。
4. なので、いつものSeaquenceClass内に作成する。

今回使用するFileSystemObjectは、遅いけどとても便利。例えば今回の目的である「フォルダ名」の取得には、GetFolderメソッドが有効だ。

クラスモジュール（SeaquenceClass）

Public Function GetSubFoldersCol(folder_path As String) As Collection
    ' Microsoft Scripting Runtimeの参照設定要
    Dim FSO As FileSystemObject
    Set FSO = New FileSystemObject
    
    Dim TempCol As Collection
    Set TempCol = New Collection
    
    Dim myFolder As Folder
        For Each myFolder In FSO.GetFolder(folder_path).SubFolders
            TempCol.Add myFolder.Name
        Next
    
    Set GetSubFoldersCol = TempCol
End Function

コレクションのままでも使用可能だが、今回要求された戻り値は配列だ。
そこでコレクションの中身が空っぽ（つまり、フォルダが無い）の場合を考慮しつつ、以下の関数を作成した。

Public Function GetSubFoldersSeq(folder_path As String) As Variant
    Dim TempCol As Collection
    Set TempCol = GetSubFoldersCol(folder_path)
    If TempCol.Count >= 1 Then
        GetSubFoldersSeq = ToArray(GetSubFoldersCol(folder_path))
    Else
        GetSubFoldersSeq = -1
    End If
End Function

Public Function ToArray(col As Collection) As Variant
    Dim seq As Variant
    ReDim seq(col.Count - 1)
    Dim c As Variant
    Dim i As Long
        i = 0
        For Each c In col
            seq(i) = c
            i = i + 1
        Next    
    ToArray = seq
End Function

今回は、コレクションが空っぽの場合の戻り値を「-1」としてみた。

この結果を、以前紹介した「PasteArray」関数でシートに貼り付けてみる。
infoment.hatenablog.com

Sub test()
    Dim SQC As New SequenceClass
    SQC.PasteArray Range("A1"), _
                   SQC.GetSubFoldersSeq("C:\Temp")
End Sub

とりあえず、上手くいきました。

参考まで。