【VBA】指定フォルダ配下(サブフォルダ含む)にある全てのExcelファイルの指定シートのセル「A1」の値を出力する

サンプルプログラム概要

・拡張子が「xlsx」のファイルのみを対象
・最初に一覧をクリアする
・Excelファイルを開いてシート[sheet1]のセル「A1」の値を取得しシートに出力する
・一覧を整形する(罫線を引く、配置を設定する)

準備

セル「B5」、「C5」、「D5」に以下を設定する

サンプルプログラム

'●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

実行結果


タイトルとURLをコピーしました