Excelとファイル検索

目的

ファイルエクスプローラの検索の使い勝手が苦手なのでExcelにファイルをリストアップして効率的に検索するためのツール（マクロ、VBA）を作ります。

要件

• パソコン内の指定したパスにあるファイルを検索する

• 検索結果は指定したシートに書き込む

• 検索結果にハイパーリンクを設定するかどうかは選択可能

ユーザインタフェース

1. パスと結果を書き込むシートを入力する

2. 検索したいパスを入力した行を選択する

3. ハイパーリンクするかどうかのプルダウンを選択する

4. 行を選択して実行ボタンを押す

ボタンシート

結果1と結果2はラベルだけ記入した空のシートをあらかじめ作成しておきます。結果はこんな感じで書き込まれます。

結果1シート

結果2シート

プログラムソース

最初によく使うパブリック変数を定義しておきます。

Public Const 最大行 = 1048576
Public Const ハイパーリンク上限 = 65530

Public Const ボタンシート名 = "ボタン"
Public Const ボタンパス列 = 1
Public Const ボタンシート列 = 2
Public Const ボタンハイパーリンク列 = 4

Public Const データパス列 = 1
Public Const データファイル列 = 2
Public Const データ拡張子列 = 3
Public Const データ年月日列 = 4
Public Const データ項目数 = 4

次にメインプログラムです。

Sub メイン()

    Call 開始処理
    
    Dim i As Long
    Dim j As Long
    Dim c As Long
    Dim ws As Worksheet
    Dim 行 As Long
    Dim パス As String
    Dim シート As String
    Dim ハイパーリンク As String
    Set ws = Sheets(ボタンシート名)
    ws.Activate
    
    'ボタンシートの情報読込----------------------------------------------------
    行 = ActiveCell.row
    パス = Trim(ws.Cells(行, ボタンパス列).Value)
    シート = Trim(ws.Cells(行, ボタンシート列).Value)
    ハイパーリンク = Trim(ws.Cells(1, ボタンハイパーリンク列).Value)
    
    'パスおよびシートが存在しないとき------------------------------------------
    If パス = "" Or シート = "" Then
        Call 終了処理
        Exit Sub
    ElseIf パス存在チェック(パス) = False Or シート存在チェック(シート) = False Then
        Call 終了処理
        Exit Sub
    End If
    
    'ファイル検索--------------------------------------------------------------
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    c = 0
    ReDim 書込データ(1 To データ項目数, 1 To 1) As Variant
    
    Call ファイル検索(書込データ, c, パス, fso)
    
    '結果の書き込み------------------------------------------------------------
    If c > 0 Then
        Call 転置書込(書込データ, c, データ項目数, シート)
        
        'ハイパーリンク--------------------------------------------------------
        If InStr(ハイパーリンク, "する") > 0 Then
            Call ハイパーリンク設定(シート)
        End If
        
    Else
        MsgBox ("ファイルが見つかりません")
    End If
    
    Call 終了処理

End Sub

ファイル検索の核となるファイル検索サブです。ファイルシステムオブジェクト（FileSystemObject）を利用します。サブフォルダも検索するために再帰プログラムとして組み込みます。

Sub ファイル検索(ByRef 書込データ As Variant, ByRef c As Long, ByVal パス As Variant, _
    ByRef fso As Object)
    
    Dim p As Variant
    Dim f As Variant
    
    ' フォルダ内のサブフォルダを検索-------------------------------------------
    For Each p In fso.GetFolder(パス).SubFolders
        '再帰
        Call ファイル検索(書込データ, c, p, fso)
    Next p

    ' フォルダ内のファイルを検索-----------------------------------------------
    For Each f In fso.GetFolder(パス).Files
        
        c = c + 1
        If c = 1 Or c Mod 1000 = 0 Then
            Application.StatusBar = "ファイルを検索しています.." & c
            DoEvents
        End If
        
        ReDim Preserve 書込データ(1 To データ項目数, 1 To c) As Variant
        書込データ(データパス列, c) = fso.GetParentFolderName(f)
        書込データ(データファイル列, c) = f.Name
        書込データ(データ拡張子列, c) = fso.GetExtensionName(f)
        書込データ(データ年月日列, c) = f.DateLastModified
        
    Next f
    
End Sub

ハイパーリンク設定サブです。ハイパーリンクできる数に上限があるので上限を超えたらループアウトします。

Sub ハイパーリンク設定(ByVal シート As String)
        
    Dim i As Long
    Dim ws As Worksheet
    Set ws = Sheets(シート)
    ws.Activate
    
    For i = 2 To ハイパーリンク上限 + 1
        If ws.Cells(i, データパス列).Value = "" Then
            Exit For
        Else
            ws.Hyperlinks.Add _
                Anchor:=ws.Range(Cells(i, データファイル列), Cells(i, データファイル列)), _
                Address:=ws.Cells(i, データパス列).Value & "\" & ws.Cells(i, データファイル列).Value
        End If
    Next i
    
End Sub

よく使う開始処理サブと終了処理サブです。

Sub 開始処理()

    Application.ScreenUpdating = False
    Application.StatusBar = True
    Application.DisplayAlerts = False
    
End Sub

Sub 終了処理()

    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.DisplayAlerts = True

End Sub

パス存在チェックサブとシート存在チェックサブです。

Function パス存在チェック(ByVal パス As String) As Boolean

    パス存在チェック = True
    If Dir(パス, vbDirectory) = "" Then
        パス存在チェック = False
    End If

End Function

Function シート存在チェック(ByVal シート As String) As Boolean

    Dim ws As Worksheet
    シート存在チェック = False
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name = シート Then
            シート存在チェック = True
            Exit Function
        End If
    Next ws

End Function

最後に転置書込サブです。VBAで多次元配列を使うときにサイズを変更できるのは最後の次元のみという制約があるので、転置して書き込むというひと手間が必要です。ここではExcelの最大行を超える場合は打ち切っています。

Sub 転置書込(ByRef 書込データ As Variant, ByVal データ数 As Long, _
            ByVal 項目数 As Long, ByVal シート名 As String)

    Dim i As Long
    Dim j As Long
    Dim ws As Worksheet
    
    '行数の上限チェック--------------------------------------------------------
    If データ数 > 最大行 - 1 Then
        データ数 = 最大行 - 1
    End If
    ReDim 転置データ(1 To データ数, 1 To 項目数) As Variant
    
    '書込データを転置----------------------------------------------------------
    For i = 1 To データ数
        For j = 1 To 項目数
            転置データ(i, j) = 書込データ(j, i)
        Next j
    Next i
    
    '転置データを書き込み------------------------------------------------------
    Set ws = Sheets(シート名)
    ws.Activate
    ws.Range(Cells(2, 1), Cells(最大行, 項目数)).Clear
    ws.Range(Cells(2, 1), Cells(データ数 + 1, 項目数)).Value = 転置データ

End Sub

最後に

プログラムソースのコピペすら面倒くさいというものぐさな友人のためにExcelファイル添付しておきます。コーヒー1杯分で。笑