パパエンジニアの雑記

Excel MS VBA

【VBA】excelでサブディレクトリの階層数を取得する

投稿者 iyken

VBAを組んでいて、フォルダの階層数を指定して実行したい処理がでてきた。
subFoldersなどの関数を使い、再起処理で配下にあるフォルダへ処理を行うような記事はいくつかあった。
（前回も同じような仕組みを使った）

が、配下のサブフォルダーすべてではなく、「任意の階層数」を指定して処理を行うような記事は、さっとぐぐってもでてこなかった。
ということで、VBAで任意の階層数を指定できるようなマクロを組んでみた。

完成図

こんな感じで、下記のような処理を行うマクロ
１．対象のフォルダを選択
２．選択したフォルダから、任意の階層までに存在するファイル名と階層数を記述する

どうやって階層数をカウントするか？

少し考えて、ファイルパスに含まれる「\」（区切り文字）の数を扱えば、任意の階層数とれるんじゃね？と考えた。

どういうことか？

下記が前提としてある。
１．ベースとなるフォルダパスが定まっている
２．VBAでは、folder.subFolders()
　　という関数で、現在のフォルダ（カレントディレクトリ）のサブフォルダーをすべて取得できる
３．フォルダパスの区切り文字は、ディスクシステム上、ファイル名には定められない

ということは、
階層数　＝　サブフォルダーまでのパスに含まれる「\」の数　－　ベースのパスに含まれる「\」の数
（ベースのフォルダパスを階層0とする場合）
で求められると思う。

じゃあ実装だ！

そんなわけで、核となる部分はこんな感じ。


'ベースとするフォルダまでのパスに含まれる「\」の数を数える
Dim tgFlder As folder
Dim baseNum As Long
Dim objFso As New FileSystemObject
Set tgFlder = objFso.GetFolder(Path)
baseNum = UBound(Split(tgFlder, "\"))

'現在のベースからの階層数を調べる
Dim ctDepthNum As Long
ctDepthNum = UBound(Split(currentFolder, "\")) - baseNum

簡単に解説をすると、
UBound(Split(tgFlder, “\”))
これで、パスの中に含まれる「\」（区切り文字）の数をカウントしている。
文字列のパスを使って検索するよりも、
１．一度配列にして（split(tgFlder, “\”)
２．配列の最後のIndexを数える（UBount()）
させたほうが、処理は高速だろうと、上記のような処理。

ではコードの全容

プロジェクト構成

-VBAPProject(folderDepthSample.xlsm)
|_MicroSoft Excel Objects
| |_Sheet1(Sheet1)
|   |_「対象のディレクトリ選択」ボタンを押したときに呼ばれる関数①
|   |_「実行！」ボタンを押したときに呼ばれる関数②
| |_Sheet2(Sheet2)
| |_Sheet3(Sheet3)
| |_ThisWorkbook
|
|_標準モジュール
 |_Module1
   |_ファイル選択ロジック（「ファイル選択」ボタンから呼ばれる③
   |_サブディレクトリ含むファイル一覧表示のMain処理④
   |_サブディレクトリを含むファイル一覧表示（再起呼び出し用⑤

「対象のディレクトリ選択」ボタンを押したときに呼ばれる関数①


'ディレクトリ選択ボタン押下時
Sub btnSelectDirectory_Click()
    'エラーは無視
    On Error Resume Next

    '選択したファイルを保存するための変数
    Dim StrPath As String
    
    'ディレクトリの選択
    StrPath = Module1.fncSelectFolder()
    
    'Sheet1のB6セルに選択したディレクトリパスを記述
    If StrPath <> "" Then
        ThisWorkbook.Worksheets("Sheet1").Range("B6").Value = StrPath
    End If
End Sub

「実行！」ボタンを押したときに呼ばれる関数②


'「実行！」ボタン押下時
Sub btnExcec_click()
    Dim SubDirMaxNumString As String
    Dim SubDirMaxNum As Long '対象とする階層数
    Dim StrPath As String '対象のディレクトリ名
    
    '現在のファイル
    Dim StrWorkSheetName As String
    Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
    
    StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
    Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
    
    StrPath = BaseBookSheet.Range("B6").Value
    SubDirMaxNumString = BaseBookSheet.Range("C6").Value
    
    '対象とする階層数を取得する（数字以外の場合はエラーにする）
    If IsNumeric(SubDirMaxNumString) = False Then
        MsgBox "サブフォルダー数は、有効な数字で入力してください。"
        Exit Sub
    End If
    SubDirMaxNum = CLng(SubDirMaxNumString)
    
    'パスが入力されていない場合処理終了
    If StrPath = "" Then
        MsgBox "ファイルパスを指定してください。"
        End
    End If
    
    '実行
    Call Module1.getFilePathLists(StrPath, SubDirMaxNum)
    MsgBox "完了"

End Sub

ファイル選択ロジック（「ファイル選択」ボタンから呼ばれる③


'フォルダを選択するダイアログを表示して、パスを取得する
'返り値：選択したディレクトリ名(String型)
Function fncSelectFolder() As String
    Dim returnString As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            returnString = .SelectedItems(1)
        End If
    End With
    
    fncSelectFolder = returnString
End Function

(以下、Module1）
サブディレクトリ含むファイル一覧表示のMain処理④


'指定したフォルダの階層数を取得する
'引数：
'   対象とするサブディレクトリの階層数
Function getFilePathLists(Path As String, maxDepthNum As Long)
    'On Error Resume Next
    
    Dim tgFlder As folder
    
    '現在のファイルをメモしておく
    Dim StrWorkSheetName As String
    Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
    
    StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
    Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
    
    '最後の行取得
    Dim rowNum As Long
    rowNum = Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    'ベースとするフォルダまでのパスに含まれる「\」の数を数える
    Dim baseNum As Long
    Dim objFso As New FileSystemObject
    Set tgFlder = objFso.GetFolder(Path)
    baseNum = UBound(Split(tgFlder, "\"))
    
    '指定したディレクトリを基準に階層
    Call getFileList(tgFlder, rowNum, BaseBookSheet, baseNum, maxDepthNum)
    
End Function

サブディレクトリを含むファイル一覧表示（再起呼び出し用⑤


Function getFileList(fldr As folder, rowNum As Long, BaseBookSheet As Worksheet, baseNum As Long, maxDepthNum As Long)
    '指定されたディレクトリのファイルを取得する
    Dim tgFile As File
    
    '現在のベースからの階層数を調べる
    Dim ctDepthNum As Long
    ctDepthNum = UBound(Split(fldr, "\")) - baseNum
    
    'ディレクトリ内のファイルの数だけ繰り返す
    For Each tgFile In fldr.Files
        'ファイル名/階層数を書き出す
        BaseBookSheet.Range("B" & rowNum).Value = tgFile
        BaseBookSheet.Range("C" & rowNum).Value = ctDepthNum & "階層目"
            
        rowNum = rowNum + 1
    Next tgFile
    
    '指定した階層を超えていなければ、下の階層を調べる
    Dim tgFldr As folder
    If ctDepthNum < maxDepthNum Then
        With CreateObject("Scripting.FileSystemObject")
            For Each tgFldr In .GetFolder(fldr).subfolders
                '再帰
                Call getFileList(tgFldr, rowNum, BaseBookSheet, baseNum, maxDepthNum)
            Next tgFldr
        End With
    End If
End Function

最後に、上記で作成した2つのコードファイルをペタリしておきます。

[amazonjs asin="4774173673" locale="JP" title="Excel VBA 本格入門 ~日常業務の自動化からアプリケーション開発まで~"]

[amazonjs asin="4798047341" locale="JP" title="大村あつし の Excel VBA Win64/32 APIプログラミング"]

[amazonjs asin="4990512405" locale="JP" title="VBAエキスパート公式テキスト Excel VBA ベーシック 模擬問題プログラム付き"]

[amazonjs asin="4062577690" locale="JP" title="入門者のExcel VBA―初めての人にベストな学び方 (ブルーバックス)"]

全コード

sheet1(コード）


'ディレクトリ選択ボタン押下時
Sub btnSelectDirectory_Click()
    'エラーは無視
    On Error Resume Next

    '選択したファイルを保存するための変数
    Dim StrPath As String
    
    'ディレクトリの選択
    StrPath = Module1.fncSelectFolder()
    
    'Sheet1のB6セルに選択したディレクトリパスを記述
    If StrPath <> "" Then
        ThisWorkbook.Worksheets("Sheet1").Range("B6").Value = StrPath
    End If
End Sub


'「実行！」ボタン押下時
Sub btnExcec_click()
    Dim SubDirMaxNumString As String
    Dim SubDirMaxNum As Long '対象とする階層数
    Dim StrPath As String '対象のディレクトリ名
    
    '現在のファイル
    Dim StrWorkSheetName As String
    Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
    
    StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
    Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
    
    StrPath = BaseBookSheet.Range("B6").Value
    SubDirMaxNumString = BaseBookSheet.Range("C6").Value
    
    '対象とする階層数を取得する（数字以外の場合はエラーにする）
    If IsNumeric(SubDirMaxNumString) = False Then
        MsgBox "サブフォルダー数は、有効な数字で入力してください。"
        Exit Sub
    End If
    SubDirMaxNum = CLng(SubDirMaxNumString)
    
    'パスが入力されていない場合処理終了
    If StrPath = "" Then
        MsgBox "ファイルパスを指定してください。"
        End
    End If
    
    '実行
    Call Module1.getFilePathLists(StrPath, SubDirMaxNum)
    MsgBox "完了"

End Sub

Module2


Option Explicit

'フォルダを選択するダイアログを表示して、パスを取得する
'返り値：選択したディレクトリ名(String型)
Function fncSelectFolder() As String
    Dim returnString As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            returnString = .SelectedItems(1)
        End If
    End With
    
    fncSelectFolder = returnString
End Function

'指定したフォルダの階層数を取得する
'引数：
'   対象とするサブディレクトリの階層数
Function getFilePathLists(Path As String, maxDepthNum As Long)
    'On Error Resume Next
    
    Dim tgFlder As folder
    
    '現在のファイルをメモしておく
    Dim StrWorkSheetName As String
    Dim BaseBookSheet As Worksheet '実行するエクセルのワークブックを覚えておくため
    
    StrWorkSheetName = ActiveWorkbook.ActiveSheet.Name
    Set BaseBookSheet = ThisWorkbook.Worksheets(StrWorkSheetName)
    
    '最後の行取得
    Dim rowNum As Long
    rowNum = Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    'ベースとするフォルダまでのパスに含まれる「\」の数を数える
    Dim baseNum As Long
    Dim objFso As New FileSystemObject
    Set tgFlder = objFso.GetFolder(Path)
    baseNum = UBound(Split(tgFlder, "\"))
    
    '指定したディレクトリを基準に階層
    Call getFileList(tgFlder, rowNum, BaseBookSheet, baseNum, maxDepthNum)
    
End Function

Function getFileList(fldr As folder, rowNum As Long, BaseBookSheet As Worksheet, baseNum As Long, maxDepthNum As Long)
    '指定されたディレクトリのファイルを取得する
    Dim tgFile As File
    
    '現在のベースからの階層数を調べる
    Dim ctDepthNum As Long
    ctDepthNum = UBound(Split(fldr, "\")) - baseNum
    
    'ディレクトリ内のファイルの数だけ繰り返す
    For Each tgFile In fldr.Files
        'ファイル名/階層数を書き出す
        BaseBookSheet.Range("B" & rowNum).Value = tgFile
        BaseBookSheet.Range("C" & rowNum).Value = ctDepthNum & "階層目"
            
        rowNum = rowNum + 1
    Next tgFile
    
    '指定した階層を超えていなければ、下の階層を調べる
    Dim tgFldr As folder
    If ctDepthNum < maxDepthNum Then
        With CreateObject("Scripting.FileSystemObject")
            For Each tgFldr In .GetFolder(fldr).subfolders
                '再帰
                Call getFileList(tgFldr, rowNum, BaseBookSheet, baseNum, maxDepthNum)
            Next tgFldr
        End With
    End If
End Function

あとは、Sheet1当たりに、ボタンを配置して、ボタンにSheet1のアクションを紐づけてあげれば完成。

投稿者 iyken

関連投稿

Excel MS VBA

【VBA】excelで不要なStyleを削除する

iyken

コメントを残す

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

見逃しています

未分類

headタグがbodyタグに出てしまう

名言録

[読書名言録]仕事は楽しいかね？

wordpress 困ったシリーズ

【WordPress】画像アップロード中にエラー

Excel MS VBA

【VBA】excelでサブディレクトリの階層数を取得する