サンプルプログラム概要
・拡張子が「xlsx」のファイルのみを対象
・最初に一覧をクリアする
・Excelファイルを開いてシート[sheet1]のセル「A1」の値を取得しシートに出力する
・一覧を整形する（罫線を引く、配置を設定する）
準備
「見出し」を以下を設定する。
セル「B5」：NO
セル「C5」：FILEPATH
セル「D5」：VALUE
サンプルプログラム
'●MainModule
Option Explicit
Sub execButton_click()
Dim inputFolder As String
Dim isPathExist As String
'初期化処理
Call init(False)
'フォルダパスを取得
inputFolder = Application.InputBox(Prompt:="フォルダパスを入力してください", _
Title:="フォルダパス入力")
'キャンセルを押されたら終了
If inputFolder = "False" Then
Exit Sub
End If
'フォルダの入力必須チェック
If inputFolder = "" Then
MsgBox "フォルダが入力されていません"
Exit Sub
End If
'フォルダの存在チェック
isPathExist = Dir(inputFolder, vbDirectory)
If isPathExist = "" Then
MsgBox "フォルダが存在しません"
Exit Sub
End If
'ファイルリストを作成
Call createFileList(inputFolder)
'初期化処理
Call init(True)
End Sub
'初期化処理
'画面描画/イベント/確認メッセージ/自動計算の抑止、抑止解除
Private Function init(status As Boolean)
With Application
.ScreenUpdating = status
.EnableEvents = status
.DisplayAlerts = status
If status Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Function
'●CreateFileListModule
Option Explicit
'ファイルリストを作成
Public Function createFileList(inputFolder As String)
Dim fso As Object
'リストをクリア
Call clearList
'ファイルリストを作成
Set fso = CreateObject("Scripting.FileSystemObject")
Call execCreateFileList(inputFolder, fso)
'リストを整形
Call formatList
Set fso = Nothing
End Function
'リストをクリア
Private Function clearList()
Dim ws As Worksheet
Dim endRow As Double
Set ws = ActiveSheet
'最終行を取得
endRow = ws.Cells(START_ROW, NO_COLUMN).End(xlDown).row
'指定範囲をクリア
range(ws.Cells(START_ROW + 1, NO_COLUMN), _
ws.Cells(endRow, VALUE_COLUMN)).Clear
Set ws = Nothing
End Function
'ファイルリストを作成
Private Function execCreateFileList(inputFolder As String, fso As Object)
Const INPUT_SHEET_NAME As String = "sheet1"
Const TARGET_FILE_TYPE As String = "xlsx"
Dim file As Object
Dim folders As Object
Dim ws As Worksheet
Dim row As Double
Dim wk As Workbook
'サブフォルダ取得
For Each folders In fso.getFolder(inputFolder).SubFolders
Call execCreateFileList(folders.Path, fso)
Next
Set ws = ActiveSheet
'書き込む行を取得(下から上を見ていく)
row = ws.Cells(MAX_ROW, NO_COLUMN).End(xlUp).row + 1
'ファイル数分繰り返し
For Each file In fso.getFolder(inputFolder).files
If LCase(fso.GetExtensionName(file.Name)) = TARGET_FILE_TYPE Then
'Excelファイルを開く ※「リンクの更新」はしないで開く
Set wk = Workbooks.Open(Filename:=file.Path, UpdateLinks:=0)
'一覧に出力
ws.Cells(row, NO_COLUMN).Value = row - START_ROW
ws.Cells(row, FILEPATH_COLUMN).Value = file.Path
ws.Cells(row, VALUE_COLUMN).Value = wk.Sheets(INPUT_SHEET_NAME).range("A1").Value
'Excelファイルを保存せず閉じる
wk.Close SaveChanges:=False
row = row + 1
End If
Next
'後片付け
Set ws = Nothing
Set wk = Nothing
End Function
'リストを整形
Private Function formatList()
Dim ws As Worksheet
Dim endRow As Double
Set ws = ActiveSheet
'最終行を取得
endRow = ws.Cells(START_ROW, NO_COLUMN).End(xlDown).row
'上下左右に罫線(実線)を引く
range(ws.Cells(START_ROW + 1, NO_COLUMN), _
ws.Cells(endRow, VALUE_COLUMN)).Borders.LineStyle = xlContinuous
'「項番列の水平位置/垂直位置を真ん中寄せにする
range(ws.Cells(START_ROW + 1, NO_COLUMN), _
ws.Cells(endRow, NO_COLUMN)).HorizontalAlignment = xlCenter
range(ws.Cells(START_ROW + 1, NO_COLUMN), _
ws.Cells(endRow, NO_COLUMN)).VerticalAlignment = xlCenter
'「ファイルパス列」の水平位置/垂直位置を左上にする
range(ws.Cells(START_ROW + 1, FILEPATH_COLUMN), _
ws.Cells(endRow, FILEPATH_COLUMN)).HorizontalAlignment = xlLeft
range(ws.Cells(START_ROW + 1, FILEPATH_COLUMN), _
ws.Cells(endRow, FILEPATH_COLUMN)).VerticalAlignment = xlTop
Set ws = Nothing
End Function'●PublicModule
Public Const NO_COLUMN As Integer = 2
Public Const FILEPATH_COLUMN As Integer = 3
Public Const VALUE_COLUMN As Integer = 4
Public Const START_ROW As Integer = 5
Public Const MAX_ROW As Double = 1048576実行結果
