VBAサンプル集
エクセルでファイル一覧を作成.№10（完成）

Option Explicit

Public Const cnsRow As Long = 4 '開始行
Public Const cnsCol As Long = 2 '開始列
Public ColMax As Long　　　　 '最終列

Sub ファイル一覧取得()
　　Dim objFSO As FileSystemObject
　　Dim strDir As String
　　Dim i As Long, j As Long
　　
　　strDir = Cells(cnsRow, cnsCol)
　　'FileSystemObjectのインスタンスの生成
　　Set objFSO = New FileSystemObject
　　'フォルダの存在確認
　　If Not objFSO.FolderExists(strDir) Then
　　　　MsgBox ("指定のフォルダは存在しません")
　　　　Exit Sub
　　End If
　　'画面描画を停止
　　Application.ScreenUpdating = False
　　'表示領域を初期設定
　　Range(Rows(cnsRow), Rows(Cells.SpecialCells(xlCellTypeLastCell).Row)).Clear
　　Cells(cnsRow, cnsCol) = strDir
　　'開始行列
　　i = cnsRow + 1
　　j = cnsCol
　　ColMax = cnsCol
　　'再帰処理モジュールのコール
　　Call GetDirFiles(objFSO.GetFolder(strDir), i, j)
　　'オブジェクトの解放
　　Set objFSO = Nothing
　　'列幅を調整
　　Range(Columns(cnsCol), Columns(Columns.Count)).ColumnWidth = 3
　　Range(Columns(ColMax), Columns(ColMax + 2)).EntireColumn.AutoFit
　　'サイズ、更新日時の罫線設定
　　Call SetLine2(Range(Cells(cnsRow, ColMax + 1), Cells(i - 1, ColMax + 2)))
　　'見出し行の外枠罫線
　　Call SetLine3(Range(Cells(cnsRow, cnsCol), Cells(cnsRow, ColMax + 2)))
　　'一覧部分の外枠罫線
　　Call SetLine3(Range(Cells(cnsRow + 1, cnsCol), Cells(i - 1, ColMax + 2)))
　　'見出しの書式設定
　　Cells(cnsRow, ColMax).Font.Bold = True
　　With Cells(cnsRow, ColMax + 1)
　　　　.Value = "サイズ"
　　　　.HorizontalAlignment = xlRight
　　End With
　　With Cells(cnsRow, ColMax + 2)
　　　　.Value = "更新日時"
　　　　.HorizontalAlignment = xlRight
　　End With
　　'指定フォルダに移動しておく
　　Cells(cnsRow, cnsCol).Select
　　'ステータスバーを消して、描画再開
　　Application.StatusBar = False
　　Application.ScreenUpdating = True
End Sub

Sub GetDirFiles(ByVal objFolder As Folder, ByRef i As Long, ByRef j As Long)
　　Dim objFolderSub As Folder
　　Dim objFile As File
　　Dim strSplit() As String
　　'ステータスバーに処理中のフォルダを表示
　　Application.StatusBar = objFolder.Path
　　'最終列が増えた場合は、サイズの前に1列追加する
　　If j > ColMax Then
　　　　Columns(j).Insert Shift:=xlToRight
　　　　ColMax = j
　　End If
　　'サブフォルダの取得
　　For Each objFolderSub In objFolder.SubFolders
　　　　Cells(i, j) = objFolderSub.Name
　　　　'フォルダにハイパーリンクを設定する場合
　　　　'ActiveSheet.Hyperlinks.Add _
　　　　'　　　　　　Anchor:=Cells(i, j), _
　　　　'　　　　　　Address:=objFolderSub.Path, _
　　　　'　　　　　　TextToDisplay:=objFolderSub.Name
　　　　Call SetLine1(i, j)
　　　　i = i + 1
　　　　Call GetDirFiles(objFolderSub, i, j + 1)
　　Next
　　'ファイルの取得
　　For Each objFile In objFolder.Files
　　　　With objFile
　　　　　　Cells(i, j) = .Name
　　　　　　strSplit = Split(objFile.Path, ".")
　　　　　　If UBound(strSplit) > 0 Then
　　　　　　　　Select Case LCase(strSplit(UBound(strSplit)))
　　　　　　　　　　Case "xls", "xlsx"
　　　　　　　　　　　　ActiveSheet.Hyperlinks.Add _
　　　　　　　　　　　　　　　　　　Anchor:=Cells(i, j), _
　　　　　　　　　　　　　　　　　　Address:=.Path, _
　　　　　　　　　　　　　　　　　　TextToDisplay:=.Name
　　　　　　　　End Select
　　　　　　End If
　　　　　　Cells(i, ColMax + 1) = WorksheetFunction.RoundUp(.Size / 1024, 0)
　　　　　　Cells(i, ColMax + 1).NumberFormatLocal = "#,##0 ""KB"""
　　　　　　Cells(i, ColMax + 2) = .DateLastModified
　　　　　　Cells(i, ColMax + 2).NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"
　　　　　　Call SetLine1(i, j)
　　　　　　i = i + 1
　　　　End With
　　Next
　　'オブジェクトの解放
　　Set objFolderSub = Nothing
　　Set objFile = Nothing
End Sub

'フォルダ名、ファイル名の行の罫線
Sub SetLine1(ByVal i As Long, ByVal j As Long)
　　If j > cnsCol Then
　　　　With Range(Cells(i, cnsCol), Cells(i, j - 1))
　　　　　　.Borders(xlEdgeLeft).LineStyle = xlContinuous
　　　　　　.Borders(xlInsideVertical).LineStyle = xlContinuous
　　　　End With
　　End If
　　With Range(Cells(i, j), Cells(i, ColMax + 2))
　　　　.Borders(xlEdgeLeft).LineStyle = xlContinuous
　　　　.Borders(xlEdgeTop).LineStyle = xlContinuous
　　End With
End Sub

'サイズ、更新日時の罫線設定
Sub SetLine2(ByRef myRange As Range)
　　With myRange.Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlHairline
　　End With
　　With myRange.Borders(xlInsideVertical)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlHairline
　　End With
End Sub

'外枠罫線、少し太く
Sub SetLine3(ByRef myRange As Range)
　　With myRange.Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　End With
　　With myRange.Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　End With
　　With myRange.Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　End With
　　With myRange.Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlMedium
　　End With
End Sub

Private Sub btnフォルダ_Click()
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If .Show = True Then
　　　　　　Cells(cnsRow, cnsCol) = .SelectedItems(1)
　　　　End If
　　End With
End Sub

Private Sub btn実行_Click()
　　Call ファイル一覧取得
End Sub