「VBA」カテゴリーアーカイブ

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

結論

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

【保存先を指定するだけ】シートをPDF一括出力するVBA

毎月のPDF出力、手作業だとつらくないですか？

月末になると、何枚ものシートを 1つずつPDFに保存する作業 に追われていませんか？

毎月の帳票をPDF化するのがとにかく面倒
「名前を付けて保存」を何度も繰り返す
保存先を間違えて、探すのに時間がかかる

こうした“よくある悩み”は、ExcelのVBAを使えば たった1クリック で解消できます。

「保存先フォルダを選ぶだけ」で、複数のシートを自動でPDF化する仕組みを作ってみましょう。

手作業でPDF化するときの問題点

1シートずつ「名前を付けて保存」を繰り返す負担

PDF化は地味ですが、意外と時間を使います。

保存先指定ミス・ファイル名のばらつき

担当者ごとに保存名がバラバラになり、後で探すのが大変になることも…。

忙しい月末に時間を奪われる

本来すべき“判断業務”ではなく、“作業”に時間が奪われてしまいます。

VBAで一括PDF化するとこうなる

保存先フォルダを選ぶだけでPDFが自動保存
複数シートを 順番にまとめて一括出力
ファイル名も自動で統一でき、ミスが激減

月末のストレスが一気に減り、本来の業務に集中できます。

事前準備：VBAを動かす前に必要なもの

マクロ有効ブック（.xlsm）で保存する
PDF保存用のフォルダを作成しておく
各シートの印刷範囲・ページ設定を確認しておく
- 印刷設定が崩れていると、余白だらけのPDFが出ます。

【コピペOK】複数シートをPDF一括出力する基本VBA

コードの概要（初心者向け解説）

実行すると「保存先を選ぶダイアログ」が開く
アクティブブック内の すべてのシート を1枚ずつPDF化
PDF名は「シート名.pdf」
保存先のフォルダが1つ決まれば、あとは自動で実行されます

コピペ用コード（基本版）

Sub ExportSheetsToPDF()

    Dim ws As Worksheet
    Dim folderPath As String
    
    '保存先フォルダを選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "PDFの保存先フォルダを選んでください"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "処理をキャンセルしました。"
            Exit Sub
        End If
    End With
    
    '各シートをPDF保存
    For Each ws In ThisWorkbook.Worksheets
        ws.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=folderPath & ws.Name & ".pdf", _
            Quality:=xlQualityStandard
    Next ws
    
    MsgBox "PDF出力が完了しました！"

End Sub

応用版：さらに便利にするPDF出力VBA

① 特定シートだけPDF化する

「請求書だけ」「レポートだけ」など、必要なシートだけ出力したい場合。

Sub ExportSelectedSheets()

    Dim targetSheets As Variant
    Dim s As Variant
    Dim folderPath As String

    '出力したいシート名を配列で指定
    targetSheets = Array("請求書", "売上サマリー")

    '保存先の選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

    '指定シートを順番にPDF化
    For Each s In targetSheets
        Worksheets(s).ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=folderPath & s & ".pdf"
    Next s

    MsgBox "指定シートのPDF出力が完了しました！"

End Sub

② ファイル名に「日付」や「シート名」を自動で付与する

毎月の帳票に便利な「日付入りPDF」。

Sub ExportSheetsWithDate()

    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim todayStr As String

    todayStr = Format(Date, "yyyy-mm-dd") '日付を文字列化

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

    For Each ws In ThisWorkbook.Worksheets
        fileName = todayStr & "_" & ws.Name & ".pdf"

        ws.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=folderPath & fileName
    Next ws

    MsgBox "日付入りPDFの出力が完了しました！"

End Sub

よくあるつまづきポイントと対処法

● パス指定エラー

保存先フォルダが存在しない
ネットワークフォルダの接続が切れている

→ フォルダを再作成 or ネットワーク再接続を確認してください。

● 印刷範囲が設定されておらず、真っ白PDFになる

印刷範囲設定（PageSetup）が空の場合に起きる現象
→ 手動で印刷プレビューを確認して、印刷範囲を再設定してください。

● シート名に使えない文字があり、PDF保存に失敗する

Windowsでは \ / : * ? " < > | はファイル名に使えません。

→ シート名を変更する or Replace関数で除去するコード処理が必要です。

まとめ：毎月のPDF作業はVBAで“ワンクリック化”できます

面倒だったPDF化が一気に自動化
保存先を選ぶだけで、複数シートが自動でPDF出力
他の帳票でも同じ仕組みをそのまま使い回せる

作業時間を毎月10〜20分でも削減できれば、1年で大きな差になります。

もし「自社フォーマットに合わせた自動PDF化をしたい」「もっと複雑な帳票にも対応したい」などあれば、やさしくカスタマイズをお手伝いしますので、お気軽にご相談ください。

【コピペOK】フォルダ内のファイル名を一括取得するVBA

フォルダ内のファイル名を手で一覧化するの、つらくないですか？

毎月の報告資料づくりや、ファイルチェック作業で
「フォルダにあるファイル名を全部Excelに貼り付けたい…」
そんな場面、よくありますよね。

しかし、手作業で1つずつコピペするのは時間がかかるし、ミスも起きやすい。

この記事では、フォルダのパスを入力するだけで、
一瞬でファイル名リストを自動作成できるVBA を紹介します。

なぜ多くの人がつまずくのか（業務でよくあるシーン）

日報の添付ファイルチェック
設計データの版管理
複数部署から提出されたファイルの一覧化
監査資料の確認（ファイル存在チェック）

「ファイルが増えたり入れ替わったりするたびに手動で更新」
これがストレスの元です。

Before：手作業でファイル名をまとめると何が起きる？

手作業コピペの問題点

時間がかかる：フォルダを開いて → 名前をコピー → Excelに貼る…の繰り返し
ミスが起きやすい：1つ抜けていた、順番が違っていた、など
更新が面倒：追加・削除があるたびにやり直し

After：VBAで一覧作成するとこう変わる

一瞬で最新リストが作れる

フォルダパスを入力してボタンを押すだけで、
その時点の最新ファイル一覧が自動で取得できます。

fileSystemObject を使うと何が便利？

fileSystemObject（ファイルやフォルダを扱う仕組み）を使うと

ファイル名の取得
サイズや更新日時の取得
サブフォルダの探索
…などが簡単に扱えます。

事前準備：コードを動かすために必要なもの

1. Excelマクロの有効化とVBEの開き方

Excelを開き、ALT + F11 でVBE（マクロを書く画面）を開く
「挿入 → 標準モジュール」を選び、コードを貼り付ける
.xlsm 形式で保存する

※参照設定は不要。初心者でも混乱しないように、
VBAから直接fileSystemObjectを作成する方法を使います。

2. フォルダパスの準備

例：
C:\Users\user\Documents\TestFolder

【基本版】コピペで使える！フォルダ内のファイル名を一括取得するVBA

▼ 基本コード（フォルダ直下のファイルのみ）

Sub GetFileList_Basic()

    Dim targetPath As String
    Dim fso As Object 'fileSystemObject
    Dim folder As Object
    Dim file As Object
    Dim i As Long

    'フォルダパスをメッセージで入力
    targetPath = InputBox("一覧を作成したいフォルダのパスを入力してください。")

    If targetPath = "" Then
        MsgBox "処理を中止しました。"
        Exit Sub
    End If

    'fileSystemObject を作成
    Set fso = CreateObject("Scripting.FileSystemObject")

    '指定フォルダを取得
    On Error Resume Next
    Set folder = fso.GetFolder(targetPath)
    If folder Is Nothing Then
        MsgBox "フォルダパスが正しくありません。確認してください。"
        Exit Sub
    End If
    On Error GoTo 0

    '出力先を初期化
    Cells.ClearContents
    Range("A1").Value = "ファイル名"

    i = 2

    'フォルダ内のファイルを列挙
    For Each file In folder.Files
        Cells(i, 1).Value = file.Name
        i = i + 1
    Next file

    MsgBox "一覧作成が完了しました！"

End Sub

▼ 使い方（初心者向け）

上のコードを標準モジュールに貼り付ける
マクロを実行すると「フォルダパス入力BOX」が出る
対象フォルダのパスを貼り付けて OK
シートにファイル名が一覧で表示される

【応用版】サブフォルダも含める・拡張子で絞り込みたい場合

1. サブフォルダも含めて取得（再帰処理）

Sub GetFileList_WithSubFolder()

    Dim targetPath As String
    Dim fso As Object

    targetPath = InputBox("一覧を作成したいフォルダのパスを入力してください。")
    If targetPath = "" Then Exit Sub

    Set fso = CreateObject("Scripting.FileSystemObject")

    Cells.ClearContents
    Range("A1").Value = "フォルダ"
    Range("B1").Value = "ファイル名"

    Call SearchFolder(fso.GetFolder(targetPath), 2)

    MsgBox "サブフォルダを含めた一覧を作成しました！"

End Sub


Sub SearchFolder(targetFolder As Object, ByVal rowIndex As Long)

    Dim file As Object
    Dim subFolder As Object

    'ファイルを出力
    For Each file In targetFolder.Files
        Cells(rowIndex, 1).Value = targetFolder.Path
        Cells(rowIndex, 2).Value = file.Name
        rowIndex = rowIndex + 1
    Next file

    'サブフォルダを再帰的に検索
    For Each subFolder In targetFolder.SubFolders
        rowIndex = SearchFolder(subFolder, rowIndex)
    Next subFolder

End Sub

2. 「.xlsx だけ」など拡張子で絞り込みたい場合

If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then
    'ここだけ出力する
End If

よくあるエラーとつまづきポイント

1. パスが間違っている場合

症状：メッセージで「フォルダパスが正しくありません」と表示
対処：フォルダを右クリック → パスをコピーで正しい文字列を使用

2. 参照設定は必要？

今回のコードは CreateObject を使っているため、
「参照設定」をいじる必要はありません。初心者でも安心です。

3. ファイルが多すぎて遅い場合

数万ファイルを扱うとExcelが重くなる
対応策：
- サブフォルダを分けて処理
- 絞り込み（拡張子フィルタ）を利用
- 一覧作成だけなら CSV に出力する方法も可

まとめ：作業時間が大幅に削減される

手作業でやっていたファイル名リスト作成が、
たった数秒で自動化されるようになります。

業務の報告資料づくり、監査対応、ファイル管理など、
さまざまなシーンで活用できるので、ぜひ一度試してみてください。

最後に…
もし「自分用にもっとカスタムしたい」「業務に合わせた自動化が必要」などあれば、
ココナラでも気軽に相談いただけます。あなたの業務効率化をお手伝いします。