ファイルの一覧表を作成する

はじめに

更新するたびに増えるソースコードの一覧表を自動生成したい。
一覧表はExcelで作成するので、ExcelVBAで完結させたい。

Excelファイルのサンプル

「マクロ実行」シート

除外ファイルを指定したものは、ファイル一覧に出力されない

ファイル一覧出力先の「工程１」～「工程３」シート

ここにファイル一覧を書き出す
・１行目はタイトルを指定
・２行目は各機能ごとのフォルダ相対パスを指定

実行結果

・１列目にすべての機能のファイル一覧を出力(重複なし）
・２列目以降に、各機能ごとのファイル一覧を出力

実装

サンプルコード

サンプルコード

Module1.bas

Option Explicit

Private Const RANGE_ROOT_PATH = "B1"
Private Const SHEET_OUTPUT = "Sheet2"
Private Const RANGE_IGNORE_FILE_START = "B3"

Private Const PROCESS_MAX = 3
Private Const FUNCTION_MAX = 3
Private Const SHEET_PROCESS_01 = "工程1"
Private Const SHEET_PROCESS_02 = "工程2"
Private Const SHEET_PROCESS_03 = "工程3"
Private Const RANGE_FUNCTION_01_01 = "C5"

Private Const RANGE_FUNCTION_PATH = "B2"
Private Const RANGE_START = "B3"
Private Const RANGE_ALL_START = "A3"

Private Const PATH_NONE = "NONE"


' ==================================================
' title : ファイル一覧表の作成
' input : なし
' return: なし
' ==================================================
Public Sub main()

    Dim I As Long
    Dim J As Long
    Dim ActiveSheetName As String
    Dim ResCode As Integer
    Dim RootPath As String
    Dim RangeStartRow As Long
    Dim RangeStartColumn As Long
    Dim RangeFunctionPathRow As Long
    Dim FunctionPath As String
    Dim SearchPath As String
    Dim AllFileOutputRow As Long
    Dim SortColumn As Range
    Dim DataRange As Range
    Dim SelectCount As Long

    ' シート一覧の初期化
    Dim ListSheetName() As Variant
    ListSheetName = Array(SHEET_PROCESS_01, SHEET_PROCESS_02, SHEET_PROCESS_03)
    
    ' 除外ファイルリストの作成
    Dim ListIgnoreFile() As String
    SelectCount = CellSelectDown(RANGE_IGNORE_FILE_START)
    If SelectCount > 0 Then
        ReDim ListIgnoreFile(0 To SelectCount - 1) As String
        For I = 0 To SelectCount - 1
            ListIgnoreFile(I) = Selection(I + 1)
        Next I
    End If
    
    ActiveSheetName = ActiveSheet.Name
    RootPath = ActiveSheet.Range(RANGE_ROOT_PATH).Value

    RangeStartRow = Range(RANGE_START).Row
    RangeStartColumn = Range(RANGE_START).Column
    RangeFunctionPathRow = Range(RANGE_FUNCTION_PATH).Row
    
    For I = 0 To PROCESS_MAX - 1
        ' 更新するシートに切り替える
        Sheets(ListSheetName(I)).Activate

        ' ファイル一覧を作成する
        For J = 0 To FUNCTION_MAX - 1
            ' ファイル名一覧の出力先セルに移動
            ActiveSheet.Cells(RangeStartRow, RangeStartColumn + J).Select
            
            ' ファイル一覧をクリアする
            Range(ActiveCell, ActiveCell.End(xlDown)).Clear
            ActiveSheet.Cells(RangeStartRow, RangeStartColumn + J).Select

            ' ファイル一覧の検索条件を作成
            FunctionPath = ActiveSheet.Cells(RangeFunctionPathRow, RangeStartColumn + J).Value
            SearchPath = RootPath + "\" + FunctionPath + "\*.*"

            ' 相対パスが"NONE"の場合はスキップする
            If FunctionPath <> PATH_NONE Then
                ResCode = CreateFileList(SearchPath, ListIgnoreFile())
            End If
        Next J

        ' すべてのファイル一覧（重複なし）を作成する
        ' ファイル一覧をクリアする
        Range(RANGE_ALL_START).Select
        Range(ActiveCell, ActiveCell.End(xlDown)).Clear
        
        For J = 0 To FUNCTION_MAX - 1
            ' ファイル名書込み開始位置を探す
            Cells(1, Range(RANGE_ALL_START).Column).End(xlDown).Select
            AllFileOutputRow = Selection.Row + 1

            ' ファイル一覧を選択
            SelectCount = CellSelectDown(Cells(RangeStartRow, RangeStartColumn + J).Address)
            If SelectCount > 0 Then
                ' ファイル一覧をコピー
                Selection.Copy
                Cells(AllFileOutputRow, Range(RANGE_ALL_START).Column).Select
                ActiveSheet.Paste
            End If
        Next J

        ' ソートする（昇順）
        Range(RANGE_ALL_START).Select
        Set SortColumn = Range(ActiveCell, ActiveCell.End(xlDown))
        SortColumn.Sort key1:=SortColumn, order1:=xlAscending, Header:=xlNo

        ' 重複を削除する
        Range(RANGE_ALL_START).Select
        Set DataRange = Range(ActiveCell, ActiveCell.End(xlDown))
        DataRange.RemoveDuplicates Columns:=Array(1), Header:=xlNo

        Range("A1").Select
    Next I

    ' [マクロ実行]シートへ戻る
    Sheets(ActiveSheetName).Activate
    Range("A1").Select

End Sub

' ==================================================
' title : ファイル一覧の作成
' input : SearchPath    検索するパス
' return: 0             正常終了
' note  : 文字列は大文字に変換して比較する(完全一致）
' ==================================================
Private Function CreateFileList(SearchPath As String, _
                                IgnoreFileList() As String) As Integer

    Dim result As Integer
    Dim Filename As String

    result = 0

    Filename = Dir(SearchPath, vbNormal)
    Do While Len(Filename) > 0
        If Not IsListMaech(IgnoreFileList, Filename) Then
            ActiveCell.Value = Filename
            ActiveCell.Offset(1, 0).Select
        End If

        Filename = Dir()
    Loop

    CreateFileList = result

End Function

' ==================================================
' title : セル選択（下方向）
' input : RangeStart    開始セル位置
' return: 選択した件数
'       : 選択状態のためSelectionでアクセス可能
' ==================================================
Private Function CellSelectDown(RangeStart As String) As Long

    Dim result As Long

    result = 0

    Range(RangeStart).Select
    If ActiveCell.Value = "" Then
        ' 選択なし
    Else
        If ActiveCell.Offset(1, 0).Value = "" Then
            ' 1つしか選択項目がない
        Else
            ' 複数選択項目がある
            Range(ActiveCell, ActiveCell.End(xlDown)).Select
        End If
        
        result = Selection.Rows.Count
    End If

    CellSelectDown = result

End Function

' ==================================================
' title : 配列に指定文字が登録されているかチェックする
' input : DataList()    文字配列
'       : CheckValue    チェックする文字
' return: True          登録あり
' ==================================================
Private Function IsListMaech(DataList() As String, _
                             CheckValue As String) As Boolean

    Dim result As Boolean
    Dim Value As Variant

    result = False
    For Each Value In DataList
        If StrComp(UCase(Value), UCase(CheckValue), vbTextCompare) = 0 Then
            result = True
            Exit For
        End If
    Next

    IsListMaech = result

End Function
'''

</details>