はじめに

フォルダの階層情報を調べシートに書き出します

プロシジャーの説明

任意のフォルダの階層情報を調べシートに書き出します。調査対象はフォルダに限定しフォルダ毎に容量を記録します。調査対象が広い時は5分以上時間がかかります。進捗がわかるようにテキスト形式のログファイルを記録するように仕掛けを作りました。

パラメータのイメージ

ログファイルのイメージ

サンプル１

Option Explicit
    Dim Counti As Long         '★ログファイルの進捗
    Dim Kaisoui As Long        '階層用
    Dim folderPath As String   '確認するフォルダパス
    Dim logFile As String      '★ログファイルフルパス
    Dim Logstepi As Byte       '★ログファイルの進捗のステップ
    
Sub ListFoldersInFolder()
    Dim ws As Worksheet
    Dim folderData As Collection
    Dim folderArray() As Variant
    Dim i As Long
    Dim startTime As Double
    Dim endTime As Double
    Dim elapsedTime As Double
    Dim logText As String
    Dim fileNum As Integer
    Counti = 1
    'パラメータ読込み
    Call FuncParayomi
    '★ログファイル
    fileNum = FreeFile
    ' 処理開始時間を記録
    startTime = Timer
    ' パフォーマンス向上のために更新を停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ' FolderListワークシートを削除
    Call DeleteFolderListSheet
    ' 新しいワークシートを作成
    Set ws = Worksheets.Add
    ws.Name = "FolderList"
    ' ヘッダーを設定
    With ws
        .Cells(1, 1).Value = "Folder Path"
        .Cells(1, 2).Value = "Folder Name"
        .Cells(1, 3).Value = "Folder Size (KB)"
    End With
    ' コレクションの初期化
    Set folderData = New Collection
    ' ★ログファイルを開く
    Open logFile For Output As #fileNum
    ' ★処理終了のログ出力 ヘッダー
    logText = "Start: " & Now & vbCrLf
    Print #fileNum, logText
    ' フォルダとサブフォルダの情報を一覧
    Call ListFolders(folderPath, folderData, 0, fileNum)
    ' コレクションから配列に変換
    ReDim folderArray(1 To folderData.Count, 1 To 3)
    For i = 1 To folderData.Count
        folderArray(i, 1) = folderData(i)(1)
        folderArray(i, 2) = folderData(i)(2)
        folderArray(i, 3) = folderData(i)(3)
    Next i
    ' 配列をシートに転記
    If folderData.Count > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(folderData.Count + 1, 3)).Value = folderArray
    End If
    ' 処理終了時間を記録
    endTime = Timer
    ' 処理時間を計算
    elapsedTime = endTime - startTime
    ' ★処理終了のログ出力 フッダー
    logText = "End: " & Now & vbCrLf & "Time: " & Format(elapsedTime, "0.00") & " second" & vbCrLf
    Print #fileNum, logText
    ' ★ログファイルを閉じる
    Close #fileNum
    ' 更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    ' 処理時間を表示
    MsgBox "処理時間: " & Format(elapsedTime, "0.00") & " 秒"
End Sub

Sub ListFolders(folderPath As String, ByRef folderData As Collection, level As Integer, fileNum As Integer)
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim folderInfo(1 To 3) As Variant
    Dim folderSize As Double
    Dim logText As String
    ' 階層の制限　Kaisoui
    If level > Kaisoui Then Exit Sub
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(folderPath)
    ' フォルダサイズの初期化
    folderSize = 0
    ' フォルダ内の各ファイルを処理
    folderSize = GetFolderSize(folderPath)
    ' フォルダ情報を追加
    folderInfo(1) = folder.Path ' フォルダパス
    folderInfo(2) = folder.Name ' フォルダ名
    folderInfo(3) = folderSize ' フォルダのサイズ(KB)
    folderData.Add folderInfo
    If (Counti Mod Logstepi = 0) Then
        '★フォルダのログ出力　内容
        logText = "Counti: " & Counti & vbCrLf
        Print #fileNum, logText
    Else
    End If
    Counti = Counti + 1
    ' サブフォルダ内のフォルダを処理
    For Each subFolder In folder.SubFolders
        Call ListFolders(subFolder.Path, folderData, level + 1, fileNum)
    Next subFolder
End Sub

Function GetFolderSize(folderPath As String) As Double
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    Dim folderSize As Double
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(folderPath)
    ' フォルダサイズの初期化
    folderSize = 0
    ' フォルダ内の各ファイルを処理
    For Each file In folder.Files
        folderSize = folderSize + file.Size / 1024 ' サイズをKBに変換
    Next file
    ' サブフォルダ内のサイズを加算
    For Each subFolder In folder.SubFolders
        folderSize = folderSize + GetFolderSize(subFolder.Path)
    Next subFolder
    GetFolderSize = folderSize
End Function

Function DeleteFolderListSheet()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("FolderList")
    On Error GoTo 0
    If Not ws Is Nothing Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
        MsgBox "シート 'FolderList' が削除されました。"
    Else
        MsgBox "シート 'FolderList' は存在しません。"
    End If
End Function

Function FuncParayomi()
    Sheets("パラメータ").Select
    ' ログファイルのパスを設定
    logFile = Cells(2, 2).Value
    ' フォルダパスを設定
    folderPath = Cells(3, 2).Value
    ' 階層を設定
    Kaisoui = Cells(4, 2).Value
    ' Logの記録ステップを設定
    Logstepi = Cells(5, 2).Value
End Function

サンプル２　※FreeFile関数をサブルーチン化

Option Explicit
    Dim Counti As Long         '★ログファイルの進捗
    Dim Kaisoui As Long        '階層用
    Dim folderPath As String   '確認するフォルダパス
    Dim logFile As String      '★ログファイルフルパス
    Dim Logstepi As Byte       '★ログファイルの進捗のステップ
    Dim fileNum As Integer
    Dim logText As String
    Dim elapsedTime As Double
    
Sub ListFoldersInFolder7()
    Dim ws As Worksheet
    Dim folderData As Collection
    Dim folderArray() As Variant
    Dim i As Long
    Dim startTime As Double
    Dim endTime As Double

    Counti = 1
    'パラメータ読込み
    Call FuncParayomi
    '★ログファイル
    Call FuncLogtxt(1)
    ' 処理開始時間を記録
    startTime = Timer
    ' パフォーマンス向上のために更新を停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ' FolderListワークシートを削除
    Call DeleteFolderListSheet
    ' 新しいワークシートを作成
    Set ws = Worksheets.Add
    ws.Name = "FolderList"
    ' ヘッダーを設定
    With ws
        .Cells(1, 1).Value = "Folder Path"
        .Cells(1, 2).Value = "Folder Name"
        .Cells(1, 3).Value = "Folder Size (KB)"
    End With
    ' コレクションの初期化
    Set folderData = New Collection
    ' ★ログファイルを開く
    Call FuncLogtxt(2)
    ' ★処理終了のログ出力 ヘッダー
    Call FuncLogtxt(3)
    ' フォルダとサブフォルダの情報を一覧
    Call ListFolders(folderPath, folderData, 0, fileNum)
    ' コレクションから配列に変換
    ReDim folderArray(1 To folderData.Count, 1 To 3)
    For i = 1 To folderData.Count
        folderArray(i, 1) = folderData(i)(1)
        folderArray(i, 2) = folderData(i)(2)
        folderArray(i, 3) = folderData(i)(3)
    Next i
    ' 配列をシートに転記
    If folderData.Count > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(folderData.Count + 1, 3)).Value = folderArray
    End If
    ' 処理終了時間を記録
    endTime = Timer
    ' 処理時間を計算
    elapsedTime = endTime - startTime
    ' ★処理終了のログ出力 フッダー
    Call FuncLogtxt(5)
    ' ★ログファイルを閉じる
    Call FuncLogtxt(6)
    ' 更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    ' 処理時間を表示
    MsgBox "処理時間: " & Format(elapsedTime, "0.00") & " 秒"
End Sub

Sub ListFolders(folderPath As String, ByRef folderData As Collection, level As Integer, fileNum As Integer)
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim folderInfo(1 To 3) As Variant
    Dim folderSize As Double

    ' 階層の制限　Kaisoui
    If level > Kaisoui Then Exit Sub
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(folderPath)
    ' フォルダサイズの初期化
    folderSize = 0
    ' フォルダ内の各ファイルを処理
    folderSize = GetFolderSize(folderPath)
    ' フォルダ情報を追加
    folderInfo(1) = folder.Path ' フォルダパス
    folderInfo(2) = folder.Name ' フォルダ名
    folderInfo(3) = folderSize ' フォルダのサイズ(KB)
    folderData.Add folderInfo
    If (Counti Mod Logstepi = 0) Then
        '★フォルダのログ出力　内容
        Call FuncLogtxt(4)
    Else
    End If
    Counti = Counti + 1
    ' サブフォルダ内のフォルダを処理
    For Each subFolder In folder.SubFolders
        Call ListFolders(subFolder.Path, folderData, level + 1, fileNum)
    Next subFolder
End Sub

Function GetFolderSize(folderPath As String) As Double
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    Dim folderSize As Double
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(folderPath)
    ' フォルダサイズの初期化
    folderSize = 0
    ' フォルダ内の各ファイルを処理
    For Each file In folder.Files
        folderSize = folderSize + file.Size / 1024 ' サイズをKBに変換
    Next file
    ' サブフォルダ内のサイズを加算
    For Each subFolder In folder.SubFolders
        folderSize = folderSize + GetFolderSize(subFolder.Path)
    Next subFolder
    GetFolderSize = folderSize
End Function

Function DeleteFolderListSheet()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("FolderList")
    On Error GoTo 0
    If Not ws Is Nothing Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
        MsgBox "シート 'FolderList' が削除されました。"
    Else
        MsgBox "シート 'FolderList' は存在しません。"
    End If
End Function

Function FuncParayomi()
    Sheets("パラメータ").Select
    ' ログファイルのパスを設定
    logFile = Cells(2, 2).Value
    ' フォルダパスを設定
    folderPath = Cells(3, 2).Value
    ' 階層を設定
    Kaisoui = Cells(4, 2).Value
    ' Logの記録ステップを設定
    Logstepi = Cells(5, 2).Value
End Function

Function FuncLogtxt(ByVal logi As Byte)
    If (logi = 1) Then
        '利用可能なファイル番号を取得
        fileNum = FreeFile
    ElseIf logi = 2 Then
        'ログファイルを開く
        Open logFile For Output As #fileNum
    ElseIf logi = 3 Then
        '処理終了のログ出力 ヘッダー
        logText = "Start: " & Now & vbCrLf
        Print #fileNum, logText
    ElseIf logi = 4 Then
        'フォルダのログ出力　内容
        logText = "Counti: " & Counti & vbCrLf
        Print #fileNum, logText
    ElseIf logi = 5 Then
        '処理終了のログ出力 フッダー
        logText = "End: " & Now & vbCrLf & "Time: " & Format(elapsedTime, "0.00") & " second" & vbCrLf
        Print #fileNum, logText
    ElseIf logi = 6 Then
        'ログファイルを閉じる
        Close #fileNum
    Else
    End If
End Function