結論
「設定」シートに 項目名／シート名／セル番地 を並べておけば、フォルダ内の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行で一覧化できる
- 実務版なら「順番の安定」「高速化」「失敗の見える化（エラーログ）」までできる