Contents
結論
毎回CSVを開いてコピペしているなら、VBAでフォルダ内の複数CSVを一括で読み込み、1つの「集計」シートへ追記結合できます（コピペOK）。
ヘッダーは最初の1回だけ、最終列にファイル名も記録します。実務版は取込ログで二重取り込みを防げます。
この記事でできること（ボタン1つで追記結合）
- 指定フォルダの
*.csvを順番に読み込み、同じシートに追記で結合する - 2つ目以降はヘッダーをスキップする
- 最終列に「ファイル名」を残して追跡できる
最小版 / 実務版の違い（どっちを使う？）
- 最小版：フォルダ固定。最短で動かす。※2回実行すると二重取り込みになります
- 実務版：フォルダ選択＋取込ログ。※同一フルパスは1回（上書き更新でもスキップします）
こんな人におすすめ
毎回コピペ集計で時間がかかる
日次/週次の定型作業を、1クリックにしたい人。
貼り漏れ・順番ミスなどのミスを減らしたい
目視のコピペ運用をやめて、仕組みにしたい人。
完成イメージ
追記で結合（最終行の下に追加）
既存データの下に追加されます（基本は上書きしません）。
ヘッダーは最初の1回だけ
最初のCSVだけヘッダー込み、2つ目以降はヘッダー行を読みません。
最終列に「ファイル名」を残す
後から「この行はどのCSV由来か」を追えます。
（実務版）取込ログで二重取り込み防止
同じファイル（同一フルパス）はスキップして事故を防ぎます。
まず確認：このマクロが合う前提チェック
CSVの列数（列構成）が同じ
列数が違うCSVが混ざると、結合結果が壊れます。
このコードは 列数違いを検知して停止（最小版）/スキップ（実務版） します。
区切り文字はカンマ（,）
カンマ以外（セミコロン等）だと、全部が1列に入ります。
サブフォルダは対象外（直下のみ）
C:\Work\CSV\ の直下だけ対象です（中のフォルダは見ません）。
「集計」シートは1行目がヘッダー運用
タイトル行を上に置く運用は非対応です（ヘッダーがズレます）。
注意：追記位置は「シート全体の最終使用セル」基準
「集計」シートの下にメモ/別表があると、想定より下に追記されることがあります。
集計は専用シート運用が安全です。
手順（全体像）
手順1：.xlsmで保存 → バックアップ → テストデータで実行
- .xlsm（マクロ有効）で保存
- 実行前にバックアップ（コピー推奨）
- まずは少量CSVでテスト（本番は最後）
※会社PCでマクロが禁止されている場合は、無理に突破せず社内ルールに従ってください。
手順2：VBEで標準モジュールに貼り付け
- Excelで Alt + F11（VBEを開く）
- 挿入 → 標準モジュール
- 下のコードを まるごと貼り付け（
Option Explicitから最後まで）
手順3：Alt+F8で実行（最小版 / 実務版）
- 最小版：
CSV_一括結合_最小版（フォルダ固定） - 実務版：
CSV_一括結合_実務版_ログあり（フォルダ選択＋ログ）
手順4：成功確認（「集計」「取込ログ」）
- 「集計」：ヘッダー1回＋ファイル名列が付いている
- 「取込ログ」：実務版だけ。1行＝1ファイルで記録される
コピペ用コード
最小版（フォルダ固定：最短で動かす）
FOLDER_PATHを自分の環境に変えるだけです。
実務版（フォルダ選択＋取込ログ）
- 同一フルパスは1回の仕様です（更新上書きでもスキップ）。
共通関数（フォルダ選択 / 最終行取得 / ログ処理）
- 最終行は A列基準ではなくシート全体で取得します（上書き事故対策）。
Option Explicit
'----------------------------
' 最小版：フォルダパス固定
'----------------------------
Public Sub CSV_一括結合_最小版()
Const FOLDER_PATH As String = "C:\Work\CSV" '★ここだけ自分のフォルダに変更
Const OUT_SHEET As String = "集計"
Const FILE_PATTERN As String = "*.csv"
Dim wsOut As Worksheet
Dim folder As String
Dim fileName As String, filePath As String
Dim wbCSV As Workbook
Dim wsCSV As Worksheet
Dim rng As Range
Dim outStartRow As Long
Dim includeHeader As Boolean
Dim pasteRows As Long, pasteCols As Long
Dim expectedCols As Long
Dim fileCol As Long
Dim importedFiles As Long
Dim prevScreenUpdating As Boolean
Dim hasError As Boolean
Dim errMsg As String
'--- 退避（エラーが早い段階で起きても戻せるように先に取る）
prevScreenUpdating = Application.ScreenUpdating
On Error GoTo ErrHandler
'--- 前提チェック
folder = Trim$(FOLDER_PATH)
If Right$(folder, 1) = "\" Then folder = Left$(folder, Len(folder) - 1)
If Len(Dir(folder, vbDirectory)) = 0 Then
MsgBox "フォルダが見つかりません：" & vbCrLf & folder, vbExclamation
Exit Sub
End If
fileName = Dir(folder & "\" & FILE_PATTERN)
If fileName = "" Then
MsgBox "CSVが見つかりません：" & vbCrLf & folder, vbExclamation
Exit Sub
End If
Set wsOut = GetOrCreateSheet(OUT_SHEET)
includeHeader = (WorksheetFunction.CountA(wsOut.Cells) = 0)
'--- 既に集計シートにデータがある場合は、列数（ファイル名列の手前）を推定
If Not includeHeader Then
expectedCols = GuessExpectedCols(wsOut)
End If
'--- 高速化（最低限）
Application.ScreenUpdating = False
'--- 取り込みループ
Do While fileName <> ""
filePath = folder & "\" & fileName
'CSVを開く（StartRowでヘッダーの有無を切り替え）
Workbooks.OpenText Filename:=filePath, _
Origin:=xlWindows, _
StartRow:=IIf(includeHeader, 1, 2), _
DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierDoubleQuote, _
Comma:=True
Set wbCSV = ActiveWorkbook
Set wsCSV = wbCSV.Worksheets(1)
Set rng = wsCSV.UsedRange
If WorksheetFunction.CountA(rng.Cells) > 0 Then
pasteRows = rng.Rows.Count
pasteCols = rng.Columns.Count
'--- 列数チェック（列構成が違うCSVは事故りやすいので止める）
If expectedCols = 0 Then
expectedCols = pasteCols
ElseIf pasteCols <> expectedCols Then
Err.Raise vbObjectError + 1001, , _
"列数が違うCSVが見つかりました。" & vbCrLf & _
"ファイル: " & fileName & vbCrLf & _
"想定列数: " & expectedCols & " / 今回: " & pasteCols
End If
outStartRow = GetLastRow(wsOut) + 1
'Destinationを指定してコピー（選択・クリップボード事故を減らす）
rng.Copy Destination:=wsOut.Cells(outStartRow, 1)
'ファイル名列は「データ列の次」に固定
fileCol = expectedCols + 1
'--- ファイル名列
If includeHeader Then
wsOut.Cells(outStartRow, fileCol).Value = "ファイル名"
If pasteRows > 1 Then
wsOut.Range(wsOut.Cells(outStartRow + 1, fileCol), _
wsOut.Cells(outStartRow + pasteRows - 1, fileCol)).Value = fileName
End If
includeHeader = False
Else
If wsOut.Cells(1, fileCol).Value = "" Then wsOut.Cells(1, fileCol).Value = "ファイル名"
wsOut.Range(wsOut.Cells(outStartRow, fileCol), _
wsOut.Cells(outStartRow + pasteRows - 1, fileCol)).Value = fileName
End If
importedFiles = importedFiles + 1
End If
wbCSV.Close SaveChanges:=False
Set wbCSV = Nothing
fileName = Dir()
Loop
CleanExit:
Application.CutCopyMode = False
Application.ScreenUpdating = prevScreenUpdating
If hasError Then
MsgBox errMsg, vbExclamation
Else
MsgBox "結合完了：" & importedFiles & "ファイルを取り込みました。", vbInformation
End If
Exit Sub
ErrHandler:
hasError = True
On Error Resume Next
If Not wbCSV Is Nothing Then wbCSV.Close SaveChanges:=False
On Error GoTo 0
errMsg = "エラーで停止しました。" & vbCrLf & _
"ファイル: " & fileName & vbCrLf & _
"内容: " & Err.Number & " / " & Err.Description & vbCrLf & vbCrLf & _
"※途中まで取り込まれている可能性があります。「集計」シートを確認してください。"
Resume CleanExit
End Sub
'----------------------------
' 実務版：フォルダ選択 + ログで二重取り込み防止
'----------------------------
Public Sub CSV_一括結合_実務版_ログあり()
Const OUT_SHEET As String = "集計"
Const LOG_SHEET As String = "取込ログ"
Const FILE_PATTERN As String = "*.csv"
Dim wsOut As Worksheet, wsLog As Worksheet
Dim dict As Object
Dim folder As String
Dim fileName As String, filePath As String
Dim key As String
Dim wbCSV As Workbook
Dim wsCSV As Worksheet
Dim rng As Range
Dim includeHeader As Boolean
Dim outStartRow As Long
Dim pasteRows As Long, pasteCols As Long
Dim expectedCols As Long
Dim fileCol As Long
Dim rowsImported As Long
Dim importedFiles As Long, skippedFiles As Long
Dim prevScreenUpdating As Boolean
Dim prevCalc As XlCalculation
Dim prevEvents As Boolean
Dim hasError As Boolean
Dim errMsg As String
Dim aborted As Boolean
Dim abortMsg As String
'--- 退避（復帰用）
prevScreenUpdating = Application.ScreenUpdating
prevCalc = Application.Calculation
prevEvents = Application.EnableEvents
On Error GoTo ErrHandler
'--- フォルダ選択（キャンセルなら終了）
folder = PickFolder()
If folder = "" Then Exit Sub
If Right$(folder, 1) = "\" Then folder = Left$(folder, Len(folder) - 1)
Set wsOut = GetOrCreateSheet(OUT_SHEET)
Set wsLog = GetOrCreateSheet(LOG_SHEET)
EnsureLogHeader wsLog
Set dict = CreateObject("Scripting.Dictionary")
LoadLogToDict wsLog, dict
includeHeader = (WorksheetFunction.CountA(wsOut.Cells) = 0)
'--- 既に集計シートにデータがある場合は、列数（ファイル名列の手前）を推定
If Not includeHeader Then
expectedCols = GuessExpectedCols(wsOut)
End If
'--- 高速化
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.StatusBar = "CSV取り込み準備中..."
fileName = Dir(folder & "\" & FILE_PATTERN)
If fileName = "" Then
aborted = True
abortMsg = "CSVが見つかりません：" & vbCrLf & folder
GoTo CleanExit
End If
Do While fileName <> ""
filePath = folder & "\" & fileName
key = filePath 'この実装は「同一フルパスは1回」＝更新上書きでもスキップ
If dict.Exists(key) Then
skippedFiles = skippedFiles + 1
GoTo NextFile
End If
Application.StatusBar = "取り込み中: " & fileName
Workbooks.OpenText Filename:=filePath, _
Origin:=xlWindows, _
StartRow:=IIf(includeHeader, 1, 2), _
DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierDoubleQuote, _
Comma:=True
Set wbCSV = ActiveWorkbook
Set wsCSV = wbCSV.Worksheets(1)
Set rng = wsCSV.UsedRange
If WorksheetFunction.CountA(rng.Cells) = 0 Then
skippedFiles = skippedFiles + 1
AppendLog wsLog, key, fileName, 0, "空ファイル", filePath
wbCSV.Close SaveChanges:=False
Set wbCSV = Nothing
GoTo NextFile
End If
pasteRows = rng.Rows.Count
pasteCols = rng.Columns.Count
'--- 列数チェック（列構成が違うCSVはスキップしてログに残す）
If expectedCols = 0 Then
expectedCols = pasteCols
ElseIf pasteCols <> expectedCols Then
skippedFiles = skippedFiles + 1
AppendLog wsLog, key, fileName, 0, "列数違い: 想定 " & expectedCols & " / 実際 " & pasteCols, filePath
wbCSV.Close SaveChanges:=False
Set wbCSV = Nothing
GoTo NextFile
End If
outStartRow = GetLastRow(wsOut) + 1
rng.Copy Destination:=wsOut.Cells(outStartRow, 1)
fileCol = expectedCols + 1
'--- ファイル名列
If includeHeader Then
wsOut.Cells(outStartRow, fileCol).Value = "ファイル名"
rowsImported = IIf(pasteRows > 1, pasteRows - 1, 0)
If pasteRows > 1 Then
wsOut.Range(wsOut.Cells(outStartRow + 1, fileCol), _
wsOut.Cells(outStartRow + pasteRows - 1, fileCol)).Value = fileName
End If
includeHeader = False
Else
If wsOut.Cells(1, fileCol).Value = "" Then wsOut.Cells(1, fileCol).Value = "ファイル名"
rowsImported = pasteRows
wsOut.Range(wsOut.Cells(outStartRow, fileCol), _
wsOut.Cells(outStartRow + pasteRows - 1, fileCol)).Value = fileName
End If
importedFiles = importedFiles + 1
'--- ログ追記（1行1ファイル）
AppendLog wsLog, key, fileName, rowsImported, "", filePath
dict.Add key, True
wbCSV.Close SaveChanges:=False
Set wbCSV = Nothing
NextFile:
fileName = Dir()
Loop
CleanExit:
Application.StatusBar = False
Application.CutCopyMode = False
Application.ScreenUpdating = prevScreenUpdating
Application.Calculation = prevCalc
Application.EnableEvents = prevEvents
If aborted Then
MsgBox abortMsg, vbExclamation
Exit Sub
End If
If hasError Then
MsgBox errMsg, vbExclamation
Else
MsgBox "完了しました。" & vbCrLf & _
"取り込み: " & importedFiles & " ファイル" & vbCrLf & _
"スキップ: " & skippedFiles & " ファイル（取込ログ/列数違い/空ファイル）", vbInformation
End If
Exit Sub
ErrHandler:
hasError = True
On Error Resume Next
If Not wbCSV Is Nothing Then wbCSV.Close SaveChanges:=False
On Error GoTo 0
errMsg = "エラーで停止しました。" & vbCrLf & _
"ファイル: " & fileName & vbCrLf & _
"内容: " & Err.Number & " / " & Err.Description & vbCrLf & vbCrLf & _
"※途中まで取り込まれている可能性があります。「集計」「取込ログ」を確認してください。"
Resume CleanExit
End Sub
'====================================================
' ここから下は共通関数
'====================================================
'--- フォルダ選択ダイアログ
Private Function PickFolder() As String
Dim fd As Object
Set fd = Application.FileDialog(4) 'msoFileDialogFolderPicker
With fd
.Title = "CSVが入っているフォルダを選択してください"
.AllowMultiSelect = False
If .Show = -1 Then
PickFolder = .SelectedItems(1)
Else
PickFolder = ""
End If
End With
End Function
'--- ログ見出し（空なら作る）
Private Sub EnsureLogHeader(ByVal wsLog As Worksheet)
If WorksheetFunction.CountA(wsLog.Cells) = 0 Then
wsLog.Range("A1:G1").Value = Array("FileKey(フルパス)", "FileName", "取込日時", "取込行数", "最終更新日時", "サイズ(bytes)", "備考")
End If
End Sub
'--- ログをDictionaryに読み込む
Private Sub LoadLogToDict(ByVal wsLog As Worksheet, ByVal dict As Object)
Dim lastRow As Long, r As Long
Dim key As String
lastRow = GetLastRow(wsLog)
For r = 2 To lastRow
key = CStr(wsLog.Cells(r, 1).Value)
If key <> "" Then
If Not dict.Exists(key) Then dict.Add key, True
End If
Next r
End Sub
'--- ログ追記（1行）
Private Sub AppendLog(ByVal wsLog As Worksheet, ByVal key As String, ByVal fileName As String, ByVal rowsImported As Long, ByVal note As String, ByVal filePath As String)
Dim logRow As Long
logRow = GetLastRow(wsLog) + 1
wsLog.Cells(logRow, 1).Value = key
wsLog.Cells(logRow, 2).Value = fileName
wsLog.Cells(logRow, 3).Value = Now
wsLog.Cells(logRow, 4).Value = rowsImported
On Error Resume Next
wsLog.Cells(logRow, 5).Value = FileDateTime(filePath)
wsLog.Cells(logRow, 6).Value = FileLen(filePath)
On Error GoTo 0
wsLog.Cells(logRow, 7).Value = note
End Sub
'--- 集計シートの「データ列数（ファイル名列の手前）」を推定
Private Function GuessExpectedCols(ByVal wsOut As Worksheet) As Long
Dim fileNameCol As Long
Dim lastCol As Long
fileNameCol = GetHeaderCol(wsOut, "ファイル名")
If fileNameCol > 1 Then
GuessExpectedCols = fileNameCol - 1
Exit Function
End If
lastCol = wsOut.Cells(1, wsOut.Columns.Count).End(xlToLeft).Column
GuessExpectedCols = lastCol
End Function
'--- 見出し（1行目）から列番号を探す（Trim + 大文字小文字無視）
Private Function GetHeaderCol(ByVal ws As Worksheet, ByVal headerText As String) As Long
Dim lastCol As Long, c As Long
Dim target As String, cellValue As String
target = Trim$(headerText)
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For c = 1 To lastCol
cellValue = Trim$(CStr(ws.Cells(1, c).Value))
If StrComp(cellValue, target, vbTextCompare) = 0 Then
GetHeaderCol = c
Exit Function
End If
Next c
GetHeaderCol = 0
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
'--- 最終行（シート全体）
' ※A列基準だと、A列が空の行があるCSVで「上書き事故」になり得るため避ける
Private Function GetLastRow(ByVal ws As Worksheet) As Long
Dim lastCell As Range
'まずは xlFormulas で探す（一般的）
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)
'見つからなければ xlValues でも探す
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
コードの要点（重要ポイントだけ）
ヘッダーを1回だけにしている理由（StartRow切り替え）
最初だけ StartRow=1、2つ目以降は StartRow=2 にして、ヘッダー行を読みません。
最終行の取り方（A列基準ではなくシート全体）
A列に空白があり得るCSVでも、追記位置がズレにくいようにしています（上書き事故対策）。
列数違いを検知する（事故防止）
- 最小版：列数違いが出たら停止（事故らせない）
- 実務版：列数違いはスキップしてログに残す（運用で確認できる）
ログの判定キー（同一フルパスは1回）
同じパスは二重取り込みしません。
逆に「上書き更新しても取り込まれない」のは仕様です（FAQ参照）。
よくある失敗（落とし穴）
マクロが実行できない（会社PC制限/無効化）
- 症状：Alt+F8で出ない/押しても動かない
- 原因：マクロ無効、社内ポリシー
- 対策：社内ルールに従う（無理に突破しない）
CSVが0件（フォルダ違い/サブフォルダ/拡張子）
- 症状：「CSVが見つかりません」
- 原因：フォルダが違う、直下にない、
.csvではない - 対策：まずは「同一フォルダ直下にCSV」を満たしてテスト
全部1列になる（区切りがカンマ以外）
- 症状：A列に全部入る
- 原因：区切り文字がカンマではない
- 対策：このコードはカンマ前提。区切りが違うなら仕様変更が必要
追記位置が想定より下（集計シート下に別表/メモがある）
- 症状：どんどん下に追記される
- 原因：追記位置が「シート全体の最終使用セル」基準
- 対策：「集計」シートは集計専用にし、下に別表を置かない
列数違いで止まる/スキップされる（仕様通り、ログ確認）
- 症状：最小版は停止、実務版はスキップ
- 原因：列構成が混ざっている
- 対策：CSVを揃える／揃えられないなら取り込み仕様を作り直す
FAQ（2〜4個）
UTF-8が文字化けする
Excelのバージョンや環境によって挙動が変わります。まず手動でCSVを開いて同じ症状か確認してください。
改善しない場合は、Power Queryなど別手段の方が早いこともあります。
先頭ゼロが消える（00123→123）
数値として解釈されている可能性があります。列ごとに「文字列扱い」で取り込む設定が必要です。
上書き更新したのに取り込まれない（ログがフルパス判定）
実務版は「同一フルパス＝取込済み」でスキップします。更新も取り込みたいなら、判定キー（更新日時/サイズなど）を含める設計に変えます。
大量行で遅い（高速化/別手段の検討）
ファイル数・行数が増えるとExcel自体が重くなります。
実務版（高速化ON）でも厳しければ、Power Query / Pythonなど別手段も検討対象です。
まとめ（できるようになったこと）
- フォルダ内CSVを一括で追記結合できる
- ヘッダー1回・ファイル名列・ログ運用までできる
- 列数違いは検知して事故を防げる
次の行動（CTA）
「列数がバラバラ」「文字化け」「先頭ゼロ」「遅い」など、自力で直しにくい境界に入ったら、相談で設計から整えられます（押し売りはしません）。
相談時にあると早いもの：Excel版/OS、匿名化したCSV 1〜2個、理想の集計シート（スクショ可）、行数とファイル数。