VBAサンプル1(ファイル一覧出力)

1.機能

指定したディレクトリ下のファイル情報を新規ワークシートへ出力する。(対象はサブディレクトリも含む)
対象ファイルがExcelの場合は、そのワークシート名と印刷総ページ数も出力する。

vba1_01.PNG

※Linuxでいうfindコマンドを想定したもので、Windowsコマンドでは実現が難しい。

※電子ファイル納品時のチェックやサマリ集計、PCローカルディスクの整理、共有ディレクトリの整理等に利用できます。

2.実行方法

当Excelブックを開いている状態で、開発タブ/マクロより下記いずれかのプロシジャ(マクロ)を実行する。
実行後に表示されるダイアログで対象ディレクトリを指定すると処理開始。(処理が終わらない場合、Escキーで中断・終了させる)

・getFilelist:通常版(Excel詳細情報無し)
・getFilelistDetail:Excel詳細情報追加版 ※処理時間がかかります

vba1_02.PNG

3.ダウンロードファイル

 Excelファイル(vbasample_01.xlsm)

※ファイルダウンロードができない環境の場合、下記手順でExcelブックを作成してください。

①「4.ソースコード」の内容をコピー&ペーストし、PCローカルディスクへ任意ファイル名で保存。

②Excelを起動し、空の内容で一旦、xlsm形式で保存

③VBEを開き、保存したファイルをインポート

④VBE上で参照設定を実施

4.ソースコード

■標準モジュール

Attribute VB_Name = "Module1"
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''
'ファイル一覧出力機能           2017/1/1 M.Ikeda
'
'   参照設定:MicrosoftScriptingRuntime
'
'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''
Const MAINWS_RG_DATA As String = "A2"                       '定数定義:出力シートの出力開始位置
Const CYCLE_DOEVENTS As Long = 1000                         '定数定義:DoEvents実行周期

Dim fileInfoList As Collection                              'グローバル変数:ファイルリスト情報
Dim errList As Collection                                   'グローバル変数:エラーリスト情報
Dim cntDoEvents As Long                                     'グローバル変数:DoEvents実行用カウンタ

'#######################################
'エントリポイント1
'ファイル一覧出力機能
'#######################################
Public Sub getFilelist()
    createFileList False
End Sub

'#######################################
'エントリポイント2
'ファイル一覧出力機能(詳細版)
'#######################################
Public Sub getFilelistDetail()
    createFileList True
End Sub

'#######################################
'メインメソッド
'#######################################
Private Sub createFileList(detailFlg As Boolean)
    Dim fso As FileSystemObject
    Dim fd As Folder
    Dim ws As Worksheet
    Dim row As Long
    Dim seq As Long
    
    Set fso = New FileSystemObject
    Set fileInfoList = New Collection
    Set errList = New Collection
    
    '************************************
    'フォルダ選択ダイアログ表示
    '************************************
    With Excel.Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "c:\"
        .AllowMultiSelect = False
        .Title = "フォルダの選択"
        If .Show = -1 Then
            Set fd = fso.GetFolder(.SelectedItems(1))
        Else
            Exit Sub
        End If
    End With
    
    Excel.Application.ScreenUpdating = False                '性能対応:ワークシート自動更新抑止
    Excel.Application.Calculation = xlCalculationManual     '性能対応:ワークシートの数式自動更新抑止
    Excel.Application.DisplayAlerts = False                 '処理中断抑止:警告ダイアログ表示抑止
    
    '************************************
    'ファイルリスト情報取得処理
    '************************************
    cntDoEvents = 1
    getFileInfo fd
    
    '************************************
    'ファイルリスト情報を新規ワークシートへ出力
    '************************************
    Dim fileInfo As Variant
    Set ws = createTemplateWS
    With ws
        
        'ファイルリスト情報の件数分のループ処理
        row = .Range(MAINWS_RG_DATA).row
        seq = 1
        For Each fileInfo In fileInfoList
            
            If ThisWorkbook.Path & "\" & ThisWorkbook.Name <> fileInfo(1) Then
                Dim startClm As Long
                startClm = .Range(MAINWS_RG_DATA).Column
                
                .Cells(row, startClm).Value = seq
                .Cells(row, startClm + 1).Value = fileInfo(0)
                .Cells(row, startClm + 2).Value = fileInfo(1)
                .Cells(row, startClm + 3).Value = fileInfo(2)
                .Cells(row, startClm + 4).Value = fileInfo(3)
                
                'Excelファイルである場合、そのファイルを開いて個別情報を取得・シート出力
                If detailFlg And InStr(fileInfo(2), "Excel") > 0 And fileInfo(4) = 32 Then
                    Dim buff As Variant
                    buff = getExcelInfo(CStr(fileInfo(1)))
                    .Cells(row, startClm + 5).Value = buff(0)
                    .Cells(row, startClm + 6).Value = buff(1)
                Else
                    .Cells(row, startClm + 5).Value = ""
                    .Cells(row, startClm + 6).Value = ""
                End If
                row = row + 1
                seq = seq + 1
            Else
                '開こうとするファイルがこのExcelファイル自身である場合、何もしない
                Debug.Print "target file is this file."
            End If
        Next
    End With
    
    trimWS ws
    
    Excel.Application.ScreenUpdating = True
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.DisplayAlerts = True
    Excel.Application.StatusBar = ""
    
    MsgBox "ファイルリスト出力完了。" & vbLf & _
            "ファイル数:" & seq - 1 & vbLf & _
            "エラーフォルダ数:" & errList.Count & vbLf & _
            getErrListString
End Sub

'#######################################
'再帰呼出し用のファイル情報取得処理
'#######################################
Private Sub getFileInfo(baseFolder As Folder)
    Dim fd As Folder
    Dim fl As file
    Dim fileInfo(4) As String

    On Error GoTo Err
    For Each fl In baseFolder.Files
        Erase fileInfo
        fileInfo(0) = fl.Name           'ファイル名
        fileInfo(1) = fl.Path           'ファイルパス
        fileInfo(2) = fl.Type           'ファイルの種類
        fileInfo(3) = fl.Size           'ファイルサイズ
        fileInfo(4) = fl.Attributes     'ファイル属性
        fileInfoList.Add fileInfo
        
        'ステータスバー更新
        Excel.Application.StatusBar = fl.Path & "\" & fl.Name
        
        '一定周期でOSへ制御を渡す(ESCキー受付対応)
        If cntDoEvents > CYCLE_DOEVENTS Then
            DoEvents
            cntDoEvents = 1
        Else
            cntDoEvents = cntDoEvents + 1
        End If
    
    Next
    
    For Each fd In baseFolder.SubFolders
        getFileInfo fd
    Next
    Exit Sub
    
Err:
    Debug.Print "file access error. folderName:" & baseFolder
    errList.Add baseFolder
End Sub

    
'#######################################
'Excel情報取得処理
'#######################################
Private Function getExcelInfo(fpath As String) As Variant
    Dim ret(1) As String
    Dim wsNames As String
    Dim pages As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    
    wsNames = ""
    pages = 0
    
    'Excelファイルオープン
    Set wb = GetObject(fpath)
    
    'ワークシート数分のループ処理
    For Each ws In wb.Worksheets
        'ワークシート名を取得して連結
        wsNames = wsNames & ws.Name & vbLf
        '印刷ページ数を取得
        ws.Activate
        pages = pages + Excel.Application.ExecuteExcel4Macro("get.document(50)")
    Next
    
    'Excelファイルクローズ
    wb.Close
    
    '戻り値設定処理
    Erase ret
    ret(0) = Mid(wsNames, 1, Len(wsNames) - 1)
    ret(1) = pages
    getExcelInfo = ret
End Function

'#######################################
'エラーディレクトリリスト連結
'#######################################
Private Function getErrListString() As String
    Dim v As Variant
    Dim ret As String
    For Each v In errList
        ret = ret & v & vbCrLf
    Next
    getErrListString = ret
End Function

'#######################################
'テンプレートワークシート生成
'#######################################
Private Function createTemplateWS() As Worksheet
    Set createTemplateWS = Worksheets.Add
End Function

'#######################################
'ワークシート装飾
'#######################################
Private Sub trimWS(ws As Worksheet)
    Dim header() As String
    header = Split("No.,ファイル名,ファイルパス,ファイル種類,サイズ[Byte],Excelシート名,総ページ数", ",")
    With ws
        '見出し行設定
        .Range("A1:G1") = header
        .Range("A1:G1").Interior.ColorIndex = 35
        .Range("A1:G1").AutoFilter
        '罫線
        .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).row, 7)).Borders.LineStyle = xlContinuous
        '列幅
        .Columns("A:A").ColumnWidth = 5
        .Columns("B:B").ColumnWidth = 40
        .Columns("C:C").ColumnWidth = 40
        .Columns("D:D").ColumnWidth = 20
        .Columns("E:E").ColumnWidth = 20
        .Columns("F:F").ColumnWidth = 20
        .Columns("G:G").ColumnWidth = 10
        '数値セル書式
        .Columns("E:E").NumberFormatLocal = "#,##0_ "
        'ウィンドウ枠固定
        .Range("A2").Select
        ActiveWindow.FreezePanes = True
        'セル縦位置
        .Cells.VerticalAlignment = xlTop
    End With
End Sub