Sub CombineCSVColumnsFromList()
Dim fso As Object
Dim scriptPath As String, listPath As String
Dim ts As Object, line As String
Dim csvFiles() As String, fileCount As Long
Dim i As Long, r As Long
Dim currentBook As Workbook, targetSheet As Worksheet
Dim csvBook As Workbook, csvSheet As Worksheet
Dim lastRow As Long, maxRow As Long
Dim firstFileName As String, nextFileName As String
Dim currentDate As String, excelFileName As String
' 1. マクロを実行しているExcelファイルと同じフォルダーのパスを取得
Set fso = CreateObject("Scripting.FileSystemObject")
scriptPath = ThisWorkbook.Path
listPath = fso.BuildPath(scriptPath, "list.txt")
' list.txtの存在チェック
If Not fso.FileExists(listPath) Then
MsgBox "エラー: list.txt が見つかりません。", vbCritical
Exit Sub
End If
' 2. list.txt から有効なCSVファイルのフルパスを読み込む
fileCount = 0
Set ts = fso.OpenTextFile(listPath, 1) ' 1 = ForReading
Do Until ts.AtEndOfStream
line = Trim(ts.ReadLine)
If line <> "" Then
Dim fullPath As String
fullPath = fso.BuildPath(scriptPath, line)
If fso.FileExists(fullPath) Then
ReDim Preserve csvFiles(fileCount)
csvFiles(fileCount) = fullPath
fileCount = fileCount + 1
End If
End If
Loop
ts.Close
' ファイル数のチェック
If fileCount < 2 Then
MsgBox "エラー: 有効なCSVファイルが2つ以上見つかりません。", vbCritical
Exit Sub
End If
' 画面更新と警告をオフにして高速化
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 3. 新しいワークブックを作成し、書き込み対象のシートを設定
Set currentBook = Workbooks.Add(xlWBATWorksheet)
Set targetSheet = currentBook.Sheets(1)
' 4. 1番目のCSVファイルを処理 (1列目[A列] と 3列目[C列] を抽出)
firstFileName = fso.GetBaseName(csvFiles(0))
Set csvBook = Workbooks.Open(csvFiles(0))
Set csvSheet = csvBook.Sheets(1)
lastRow = csvSheet.Cells(csvSheet.Rows.Count, "A").End(xlUp).Row
maxRow = lastRow ' 基準となる行数を保持
' ヘッダーの書き込み
targetSheet.Cells(1, 1).Value = "Col1"
targetSheet.Cells(1, 2).Value = firstFileName
' データのコピー
For r = 1 To maxRow
targetSheet.Cells(r + 1, 1).Value = csvSheet.Cells(r, 1).Value ' 1列目 (H0)
targetSheet.Cells(r + 1, 2).Value = csvSheet.Cells(r, 3).Value ' 3列目 (H2)
Next r
csvBook.Close SaveChanges:=False
' 5. 2番目以降のCSVファイルを処理 (3列目[C列] のみを横に結合)
For i = 1 To fileCount - 1
nextFileName = fso.GetBaseName(csvFiles(i))
Set csvBook = Workbooks.Open(csvFiles(i))
Set csvSheet = csvBook.Sheets(1)
' ヘッダーの書き込み (C列、D列…と右へ追加)
targetSheet.Cells(1, i + 2).Value = nextFileName
' データのコピー
For r = 1 To maxRow
targetSheet.Cells(r + 1, i + 2).Value = csvSheet.Cells(r, 3).Value ' 3列目 (H2)
Next r
csvBook.Close SaveChanges:=False
Next i
' 6. 列幅の自動調整 (AutoFit)
targetSheet.UsedRange.Columns.AutoFit
' 7. 指定のファイル名ルールでExcel 97-2003形式(.xls)で保存して閉じる
currentDate = Format(Date, "yyyyMMdd")
excelFileName = "OUTPUT_" & firstFileName & "_" & currentDate & ".xls"
' xlExcel8 = 56 (Excel 97-2003 ブック形式)
currentBook.SaveAs Filename:=fso.BuildPath(scriptPath, excelFileName), FileFormat:=56
currentBook.Close SaveChanges:=False
' 画面更新と警告を元に戻す
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "結合処理が完了しました！" & vbCrLf & excelFileName, vbInformation
End Sub
PR
