【VBA】フォルダ内の複数Excelから「指定セルだけ」抜き出して1ファイル=1行で一覧化する方法（設定シートで変更OK・コピペOK）

Contents

1 結論
2 こんな人におすすめ
3 完成イメージ
4 まず確認：このマクロが合う前提チェック
5 手順（全体像）
6 事前準備（初心者を守る）
7 「設定」シートを作る（ここだけ作れば運用がラク）
8 実行方法
9 コピペ用コード（最小版 + 実務版 + 共通関数）
10 よくある失敗（落とし穴）
11 FAQ（2〜4個）
12 まとめ

結論

「設定」シートに 項目名／シート名／セル番地 を並べておけば、フォルダ内のExcelを順番に開いて必要な値だけを抜き出し、「集計」シートに1ファイル=1行で追記できます。
セル番地が変わっても、直すのは基本「設定」シートだけです。

ポイント：セル参照は wb.Worksheets("シート名").Range("B2") のように どのブック/どのシートのセルかを明示します。Range("B2") のような無修飾は、ActiveSheet次第でズレることがあります。

こんな人におすすめ

フォルダに溜まった報告書Excelを、毎回開いてコピペしている
抜き出すセルは決まっている（でもフォーマットが微妙に変わることがある）
コード修正より「表（設定）を直して運用」したい

完成イメージ

「設定」シートに A=項目名 / B=シート名 / C=セル番地 を用意
実行すると「集計」に 列=項目、行=ファイル の表ができる
末尾列に「ファイル名」が入る（後で元ファイルを追跡できる）

まず確認：このマクロが合う前提チェック

対象は 同一フォルダ直下（サブフォルダは対象外）
取得対象のブックは、原則 パスワード無しで開けること（パスワード付きは別対応）
「集計」シートは集計専用推奨（下にメモがあると、追記位置が想定より下に出る場合があります）
ソースExcelは ReadOnlyで開き、保存せず閉じる想定です（上書き事故を避ける）

手順（全体像）

事前準備（.xlsmで保存／バックアップ／マクロ有効化の確認）
「設定」シートを作る（項目名・シート名・セル番地を並べる）
コードを貼る（標準モジュール）
実行（Alt+F8）
結果確認（集計／エラーログ）

事前準備（初心者を守る）

マクロ用ブックを .xlsm で保存
念のため コピーしてバックアップ（出力先を間違える事故に備える）
会社PCでマクロが禁止されている場合は、無理に突破せず社内ルールに従ってください

「設定」シートを作る（ここだけ作れば運用がラク）

シート名を設定にして、次の表を作ります（例はダミー）。

A列：項目名	B列：シート名	C列：セル番地
日付	報告書	B2
品番	報告書	C5
数量	報告書	E10

2行目以降が「抜き出す項目」です（1行=1項目）
セル番地は A1形式（B2 / $B$2） を推奨（まずはB2のような形で統一すると安全）

実行方法

Alt + F8 → HT002_抜き出し_最小版 を実行
- フォルダはコード内の TARGET_FOLDER を1か所変えるだけ
慣れたら：Alt + F8 → HT002_抜き出し_実務版（フォルダ選択＋ソート＋高速化＋エラーログ強化）

コピペ用コード（最小版 + 実務版 + 共通関数）

この1ブロックだけを、同じ標準モジュールに貼ればOKです（重複定義で詰まりません）。

Option Explicit

'====================================================
' HT-002: フォルダ内の複数Excelから「指定セルだけ」抜き出して集計
'
' 使い方:
'  - 最小版: HT002_抜き出し_最小版（フォルダ固定）
'  - 実務版: HT002_抜き出し_実務版（フォルダ選択 + ソート + 高速化）
'
' 設定シート（名前: 設定）:
'   A列=項目名 / B列=シート名 / C列=セル番地
'   2行目以降がデータ
'
' 出力:
'   集計シート（名前: 集計）に 1ファイル=1行 で追記
'   末尾列にファイル名
'   失敗は エラーログ（名前: エラーログ）に記録
'====================================================

Private Const SET_SHEET As String = "設定"
Private Const OUT_SHEET As String = "集計"
Private Const LOG_SHEET As String = "エラーログ"
Private Const FILE_PATTERN As String = "*.xls*"

'最小版用（★ここだけ変える）
Private Const DEFAULT_TARGET_FOLDER As String = "C:\Work\Target"

'Office/Excelの定数（参照設定に依存しないよう数値で持つ）
Private Const MSO_FILEDIALOG_FOLDERPICKER As Long = 4
Private Const MSO_AUTOMATIONSECURITY_FORCEDISABLE As Long = 3

'----------------------------
' 最小版：フォルダ固定
'----------------------------
Public Sub HT002_抜き出し_最小版()
    RunHT002 folderPath:=DEFAULT_TARGET_FOLDER, _
             useFolderPicker:=False, _
             sortFiles:=False, _
             fastMode:=False
End Sub

'----------------------------
' 実務版：フォルダ選択 + ソート + 高速化
'----------------------------
Public Sub HT002_抜き出し_実務版()
    RunHT002 folderPath:="", _
             useFolderPicker:=True, _
             sortFiles:=True, _
             fastMode:=True
End Sub

'====================================================
' 共通処理（内部）
'====================================================
Private Sub RunHT002(ByVal folderPath As String, ByVal useFolderPicker As Boolean, ByVal sortFiles As Boolean, ByVal fastMode As Boolean)

    Dim wsSet As Worksheet, wsOut As Worksheet, wsLog As Worksheet

    Dim itemNames() As String
    Dim sheetNames() As String
    Dim addresses() As String
    Dim itemCount As Long

    Dim folder As String
    Dim files As Variant
    Dim f As Variant
    Dim fileName As String, filePath As String

    Dim dataArr() As Variant
    Dim outRow As Long
    Dim i As Long

    Dim wb As Workbook
    Dim ok As Boolean

    Dim processed As Long, skipped As Long, openFailed As Long, cellFailed As Long
    Dim hasFatalError As Boolean
    Dim fatalMsg As String
    Dim aborted As Boolean
    Dim abortMsg As String

    '--- アプリ状態退避（復帰用）
    Dim prevScreen As Boolean, prevCalc As XlCalculation, prevEvents As Boolean
    Dim prevAlerts As Boolean, prevStatus As Variant
    Dim prevSec As Long

    prevScreen = Application.ScreenUpdating
    prevCalc = Application.Calculation
    prevEvents = Application.EnableEvents
    prevAlerts = Application.DisplayAlerts
    prevStatus = Application.StatusBar
    prevSec = Application.AutomationSecurity

    On Error GoTo ErrHandler

    '--- フォルダ決定
    If useFolderPicker Then
        folder = PickFolder()
        If folder = "" Then Exit Sub 'キャンセルは静かに終了
    Else
        folder = folderPath
    End If

    folder = NormalizeFolder(folder)
    If Not FolderExists(folder) Then
        MsgBox "フォルダが見つかりません：" & vbCrLf & folder, vbExclamation
        Exit Sub
    End If

    '--- 設定シート取得
    Set wsSet = GetSheetOrNothing(ThisWorkbook, SET_SHEET)
    If wsSet Is Nothing Then
        MsgBox "設定シート（" & SET_SHEET & "）が見つかりません。" & vbCrLf & _
               "シート名を「設定」にして、A:項目名 / B:シート名 / C:セル番地 を作ってください。", vbExclamation
        Exit Sub
    End If

    '--- 設定読み込み
    If Not LoadSettings(wsSet, itemNames, sheetNames, addresses, itemCount, fatalMsg) Then
        MsgBox fatalMsg, vbExclamation
        Exit Sub
    End If

    '--- 出力/ログシート
    Set wsOut = GetOrCreateSheet(OUT_SHEET)
    Set wsLog = GetOrCreateSheet(LOG_SHEET)
    EnsureLogHeader wsLog

    '--- 実務版は高速化
    If fastMode Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
        Application.DisplayAlerts = False
    End If

    Application.StatusBar = "準備中..."

    '--- 対象ファイル一覧
    If sortFiles Then
        files = GetSortedFileNames(folder, FILE_PATTERN)
        If IsEmpty(files) Then
            MsgBox "対象ファイルがありません：" & vbCrLf & folder, vbExclamation
            GoTo CleanExit
        End If
    Else
        'ソートしない場合も、いったん配列化して同じ処理に乗せる
        files = GetFileNames(folder, FILE_PATTERN)
        If IsEmpty(files) Then
            MsgBox "対象ファイルがありません：" & vbCrLf & folder, vbExclamation
            GoTo CleanExit
        End If
    End If

    '--- 出力をどうするか（実務版だけ）
    If useFolderPicker Then
        Dim ans As VbMsgBoxResult
        ans = MsgBox("「集計」シートの既存結果を消して作り直しますか？" & vbCrLf & _
                     "※戻せません。必要なら事前にバックアップしてください。", vbYesNoCancel + vbQuestion)
        If ans = vbCancel Then
            aborted = True
            abortMsg = "中止しました。"
            GoTo CleanExit
        End If

        If ans = vbYes Then
            wsOut.Cells.ClearContents
            wsLog.Cells.ClearContents
            EnsureLogHeader wsLog
        End If
    End If

    '--- ヘッダー作成（設定に合わせて毎回作る）
    WriteHeader wsOut, itemNames, itemCount

    '--- 追記開始行（最終行はシート全体で取得して上書き事故を避ける）
    outRow = GetLastRow(wsOut) + 1
    If outRow < 2 Then outRow = 2

    '--- 開くファイルのマクロを無効化（信頼できるフォルダ運用が前提）
    Application.AutomationSecurity = MSO_AUTOMATIONSECURITY_FORCEDISABLE

    '--- ファイルごとに処理
    For Each f In files

        fileName = CStr(f)

        '一時ファイル（~$）はスキップ
        If Left$(fileName, 2) = "~$" Then
            skipped = skipped + 1
            GoTo NextFile
        End If

        '自分自身（この.xlsm）を拾ったらスキップ
        If StrComp(fileName, ThisWorkbook.Name, vbTextCompare) = 0 Then
            skipped = skipped + 1
            GoTo NextFile
        End If

        filePath = folder & "\" & fileName
        Application.StatusBar = "読み込み中: " & fileName

        '--- 1行分の配列を用意
        ReDim dataArr(1 To 1, 1 To itemCount + 1)

        '--- 開く（失敗しても1ファイル=1行にしたいので、止めずに#N/Aで埋める）
        Set wb = Nothing
        Dim openErrNo As Long, openErrDesc As String

        On Error Resume Next
        Set wb = Workbooks.Open(Filename:=filePath, ReadOnly:=True, UpdateLinks:=0, AddToMru:=False)
        openErrNo = Err.Number
        openErrDesc = Err.Description
        Err.Clear
        On Error GoTo ErrHandler

        If wb Is Nothing Then
            openFailed = openFailed + 1

            For i = 1 To itemCount
                dataArr(1, i) = CVErr(xlErrNA)
            Next i
            dataArr(1, itemCount + 1) = fileName

            wsOut.Cells(outRow, 1).Resize(1, itemCount + 1).Value = dataArr
            outRow = outRow + 1

            LogError wsLog, fileName, "", "", "", "開けません: " & openErrNo & " / " & openErrDesc
            GoTo NextFile
        End If

        '--- 設定行の数だけ値を読む
        For i = 1 To itemCount
            dataArr(1, i) = GetValue2Safe(wb, sheetNames(i), addresses(i), ok)
            If Not ok Then
                cellFailed = cellFailed + 1
                LogError wsLog, fileName, itemNames(i), sheetNames(i), addresses(i), "取得失敗（シート名/セル番地を確認）"
            End If
        Next i

        dataArr(1, itemCount + 1) = fileName

        '--- 1行まとめて書き込む
        wsOut.Cells(outRow, 1).Resize(1, itemCount + 1).Value = dataArr
        outRow = outRow + 1
        processed = processed + 1

        '--- 保存せず閉じる
        wb.Saved = True
        wb.Close SaveChanges:=False
        Set wb = Nothing

NextFile:
        '次へ
    Next f

CleanExit:
    '--- 復帰
    Application.AutomationSecurity = prevSec
    Application.StatusBar = False
    Application.DisplayAlerts = prevAlerts
    Application.EnableEvents = prevEvents
    Application.Calculation = prevCalc
    Application.ScreenUpdating = prevScreen

    If aborted Then
        MsgBox abortMsg, vbExclamation
        Exit Sub
    End If

    If hasFatalError Then
        MsgBox fatalMsg, vbExclamation
        Exit Sub
    End If

    '--- 完了メッセージ（誤認を防ぐ）
    Dim msg As String
    msg = "完了しました。" & vbCrLf & _
          "処理: " & (processed + openFailed) & " ファイル（1ファイル=1行）" & vbCrLf & _
          "スキップ: " & skipped & " ファイル（~$ / 自分自身など）" & vbCrLf & _
          "開けなかった: " & openFailed & vbCrLf & _
          "セル取得失敗: " & cellFailed & vbCrLf

    If openFailed > 0 Or cellFailed > 0 Then
        msg = msg & vbCrLf & "※詳細は「" & LOG_SHEET & "」シートを確認してください。"
    End If

    MsgBox msg, vbInformation
    Exit Sub

ErrHandler:
    hasFatalError = True

    fatalMsg = "エラーで停止しました。" & vbCrLf & _
               "ファイル: " & fileName & vbCrLf & _
               "内容: " & Err.Number & " / " & Err.Description & vbCrLf & vbCrLf & _
               "※途中まで集計されている可能性があります。「集計」と「" & LOG_SHEET & "」を確認してください。"

    On Error Resume Next
    If Not wb Is Nothing Then
        wb.Saved = True
        wb.Close SaveChanges:=False
    End If
    On Error GoTo 0

    Resume CleanExit
End Sub

'====================================================
' 設定読み込み
'====================================================
Private Function LoadSettings(ByVal wsSet As Worksheet, _
                              ByRef itemNames() As String, _
                              ByRef sheetNames() As String, _
                              ByRef addresses() As String, _
                              ByRef itemCount As Long, _
                              ByRef errMsg As String) As Boolean

    Dim lastRow As Long
    lastRow = wsSet.Cells(wsSet.Rows.Count, "A").End(xlUp).Row

    If lastRow < 2 Then
        errMsg = "設定シートに項目がありません。A2:C2 から入力してください。"
        LoadSettings = False
        Exit Function
    End If

    Dim raw As Variant
    raw = wsSet.Range("A2:C" & lastRow).Value

    Dim i As Long, cnt As Long
    For i = 1 To UBound(raw, 1)
        If Trim$(CStr(raw(i, 1))) <> "" Then cnt = cnt + 1
    Next i

    If cnt = 0 Then
        errMsg = "設定シートに有効な項目がありません（A列の項目名が空です）。"
        LoadSettings = False
        Exit Function
    End If

    ReDim itemNames(1 To cnt)
    ReDim sheetNames(1 To cnt)
    ReDim addresses(1 To cnt)

    Dim idx As Long
    idx = 0
    For i = 1 To UBound(raw, 1)
        Dim item As String
        item = Trim$(CStr(raw(i, 1)))
        If item <> "" Then
            idx = idx + 1
            itemNames(idx) = item
            sheetNames(idx) = Trim$(CStr(raw(i, 2)))
            addresses(idx) = Trim$(CStr(raw(i, 3)))
        End If
    Next i

    itemCount = cnt
    LoadSettings = True
End Function

Private Sub WriteHeader(ByVal wsOut As Worksheet, ByRef itemNames() As String, ByVal itemCount As Long)
    Dim headerArr() As Variant
    Dim i As Long

    ReDim headerArr(1 To 1, 1 To itemCount + 1)
    For i = 1 To itemCount
        headerArr(1, i) = itemNames(i)
    Next i
    headerArr(1, itemCount + 1) = "ファイル名"

    wsOut.Cells(1, 1).Resize(1, itemCount + 1).Value = headerArr
End Sub

'====================================================
' 値取得（失敗は #N/A）
'====================================================
Private Function GetValue2Safe(ByVal wb As Workbook, ByVal sheetName As String, ByVal address As String, ByRef ok As Boolean) As Variant
    Dim ws As Worksheet

    ok = False

    sheetName = Trim$(sheetName)
    address = Trim$(address)
    If sheetName = "" Or address = "" Then
        GetValue2Safe = CVErr(xlErrNA)
        Exit Function
    End If

    On Error Resume Next
    Set ws = wb.Worksheets(sheetName)
    On Error GoTo 0

    If ws Is Nothing Then
        GetValue2Safe = CVErr(xlErrNA)
        Exit Function
    End If

    On Error GoTo Fail
    GetValue2Safe = ws.Range(address).Value2
    ok = True
    Exit Function

Fail:
    GetValue2Safe = CVErr(xlErrNA)
    ok = False
End Function

'====================================================
' ファイル一覧（直下のみ）
'====================================================
Private Function GetFileNames(ByVal folder As String, ByVal pattern As String) As Variant
    Dim col As Collection: Set col = New Collection
    Dim fn As String

    fn = Dir(folder & "\" & pattern)
    Do While fn <> ""
        col.Add fn
        fn = Dir()
    Loop

    If col.Count = 0 Then
        GetFileNames = Empty
        Exit Function
    End If

    Dim arr() As String
    Dim i As Long
    ReDim arr(1 To col.Count)
    For i = 1 To col.Count
        arr(i) = CStr(col(i))
    Next i

    GetFileNames = arr
End Function

Private Function GetSortedFileNames(ByVal folder As String, ByVal pattern As String) As Variant
    Dim arr As Variant
    arr = GetFileNames(folder, pattern)

    If IsEmpty(arr) Then
        GetSortedFileNames = Empty
        Exit Function
    End If

    QuickSortString arr, LBound(arr), UBound(arr)
    GetSortedFileNames = arr
End Function

Private Sub QuickSortString(ByRef arr As Variant, ByVal first As Long, ByVal last As Long)
    Dim i As Long, j As Long
    Dim pivot As String, tmp As String

    i = first: j = last
    pivot = CStr(arr((first + last) \ 2))

    Do While i <= j
        Do While StrComp(CStr(arr(i)), pivot, vbTextCompare) < 0
            i = i + 1
        Loop
        Do While StrComp(CStr(arr(j)), pivot, vbTextCompare) > 0
            j = j - 1
        Loop

        If i <= j Then
            tmp = CStr(arr(i))
            arr(i) = CStr(arr(j))
            arr(j) = tmp
            i = i + 1
            j = j - 1
        End If
    Loop

    If first < j Then QuickSortString arr, first, j
    If i < last Then QuickSortString arr, i, last
End Sub

'====================================================
' ログ
'====================================================
Private Sub EnsureLogHeader(ByVal wsLog As Worksheet)
    If GetLastRow(wsLog) = 0 Then
        wsLog.Range("A1:F1").Value = Array("日時", "ファイル名", "項目名", "シート名", "セル番地", "内容")
    End If
End Sub

Private Sub LogError(ByVal wsLog As Worksheet, ByVal fileName As String, ByVal itemName As String, _
                     ByVal sheetName As String, ByVal address As String, ByVal msg As String)

    Dim r As Long
    r = GetLastRow(wsLog) + 1
    If r < 2 Then r = 2

    wsLog.Cells(r, 1).Value = Now
    wsLog.Cells(r, 2).Value = fileName
    wsLog.Cells(r, 3).Value = itemName
    wsLog.Cells(r, 4).Value = sheetName
    wsLog.Cells(r, 5).Value = address
    wsLog.Cells(r, 6).Value = msg
End Sub

'====================================================
' 便利関数
'====================================================
Private Function PickFolder() As String
    Dim fd As Object
    Set fd = Application.FileDialog(MSO_FILEDIALOG_FOLDERPICKER)

    With fd
        .Title = "対象フォルダを選択してください"
        .AllowMultiSelect = False
        If .Show = -1 Then
            PickFolder = .SelectedItems(1)
        Else
            PickFolder = ""
        End If
    End With
End Function

Private Function GetOrCreateSheet(ByVal sheetName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = ThisWorkbook.Worksheets(sheetName)
    On Error GoTo 0

    If GetOrCreateSheet Is Nothing Then
        Set GetOrCreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        GetOrCreateSheet.Name = sheetName
    End If
End Function

Private Function GetSheetOrNothing(ByVal wb As Workbook, ByVal sheetName As String) As Worksheet
    On Error Resume Next
    Set GetSheetOrNothing = wb.Worksheets(sheetName)
    On Error GoTo 0
End Function

Private Function FolderExists(ByVal folder As String) As Boolean
    FolderExists = (Len(Dir(folder, vbDirectory)) > 0)
End Function

Private Function NormalizeFolder(ByVal folder As String) As String
    folder = Trim$(folder)
    If Right$(folder, 1) = "\" Then folder = Left$(folder, Len(folder) - 1)
    NormalizeFolder = folder
End Function

'--- 最終行（シート全体：A列基準の上書き事故を避ける）
Private Function GetLastRow(ByVal ws As Worksheet) As Long
    Dim lastCell As Range

    On Error Resume Next
    Set lastCell = ws.Cells.Find(What:="*", _
                                 After:=ws.Cells(1, 1), _
                                 LookIn:=xlFormulas, _
                                 LookAt:=xlPart, _
                                 SearchOrder:=xlByRows, _
                                 SearchDirection:=xlPrevious, _
                                 MatchCase:=False)

    If lastCell Is Nothing Then
        Set lastCell = ws.Cells.Find(What:="*", _
                                     After:=ws.Cells(1, 1), _
                                     LookIn:=xlValues, _
                                     LookAt:=xlPart, _
                                     SearchOrder:=xlByRows, _
                                     SearchDirection:=xlPrevious, _
                                     MatchCase:=False)
    End If
    On Error GoTo 0

    If lastCell Is Nothing Then
        GetLastRow = 0
    Else
        GetLastRow = lastCell.Row
    End If
End Function

よくある失敗（落とし穴）

違うセルの値が入る／結果が毎回変

原因：無修飾の Range("B2") を使ってActiveSheetを参照している
対策：必ず wb.Worksheets(sheetName).Range(address) の形で明示

エラー「Subscript out of range」／シートが見つからない

原因：「設定」のB列（シート名）が実ファイルと一致していない（スペース混入も地雷）
対策：実ファイルのシート名をコピペで合わせる。失敗は「エラーログ」を確認

#N/Aが出る（取得できない）

原因：セル番地ミス、シート名ミス、保護/パスワードなど
対策：該当行を「設定」シートで見直す（実務版はログで特定しやすい）

開くときに止まる（パスワード/特殊ダイアログ）

対策：そのファイルは「開けません」としてログに残り、行は#N/Aになります（別対応が必要）

FAQ（2〜4個）

Q：日付が数字（シリアル）になりました

A：このコードは Value2 で値を取るため、日付が数値になることがあります。表示を日付にしたい場合は「集計」シート側の表示形式で調整してください。

Q：フォルダ内の順番を日付順にしたい

A：ファイル名を YYYYMMDD_... のように揃えるのが手早いです。実務版はファイル名でソートします。

Q：実行しても0件です

A：フォルダパス（最小版）や、対象拡張子（*.xls*）、直下にファイルがあるかを確認してください。

Q：同じフォルダで何度も実行すると行が増えます

A：追記なので増えます。作り直したい場合は、実務版で「集計を消して作り直す」を選ぶか、集計シートを手動でクリアしてください（バックアップ推奨）。

まとめ

「設定」シートに シート名×セル番地 を並べるだけで、抜き出す場所を変えられる
フォルダ内の複数Excelから、必要セルだけを読んで 1ファイル=1行で一覧化できる
実務版なら「順番の安定」「高速化」「失敗の見える化（エラーログ）」までできる

結論