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
'#**********************
'#① マクロを実行しているExcelファイルと
'#同じフォルダーのパスを取得
'#**********************
Set fso = CreateObject("Scripting.FileSystemObject")
scriptPath = ThisWorkbook.Path
listPath = fso.BuildPath(scriptPath, "list.txt") '● リストファイルのパス取得
'#**********************
'#【リストファイルの存在チェック】
'#**********************
If Not fso.FileExists(listPath) Then
MsgBox "エラー: リストファイル無し", vbCritical
Exit Sub
End If
'#**********************
'#② リストファイルから対象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ファイルが２個未満", vbCritical
Exit Sub
End If
'#**********************
'#【エラーハンドリング開始】
'#**********************
On Error GoTo ErrorHandler
'#**********************
'#【処理速度の高速化】
'#【画面更新、警告、自動計算をオフ】
'#**********************
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'#**********************
'#③ 新しいワークブックを作成
'#書き込み対象のシートを設定
'#**********************
Set currentBook = Workbooks.Add(xlWBATWorksheet)
Set targetSheet = currentBook.Sheets(1)
'#**********************
'#④ 1番目のCSVファイルを処理
'#(1列目[A列] と *列目[*列] を抽出)
'#**********************
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
'#**********************
'#【データのコピー】
'#１個目のCSVファイルの１列、Ｎ列
'#**********************
For r = 1 To maxRow
targetSheet.Cells(r + 1, 1).Value = csvSheet.Cells(r, 1).Value '● 1列/A列 (H0)
'#targetSheet.Cells(r + 1, 2).Value = csvSheet.Cells(r, 2).Value '● 2列/B列 (H1)
targetSheet.Cells(r + 1, 2).Value = csvSheet.Cells(r, 3).Value '● 3列/C列 (H2)
'#targetSheet.Cells(r + 1, 2).Value = csvSheet.Cells(r, 4).Value '● 4列/D列 (H3)
'#targetSheet.Cells(r + 1, 2).Value = csvSheet.Cells(r, 5).Value '● 5列/E列 (H4)
Next r
csvBook.Close SaveChanges:=False
'#**********************
'#⑤ ２個目以降のCSVファイルを処理
'#(*列目[*列] のみを横に結合)
'#**********************
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
'#**********************
'#【データのコピー】
'#２個目のCSVファイルのＮ列
'#**********************
For r = 1 To maxRow
'#targetSheet.Cells(r + 1, i + 2).Value = csvSheet.Cells(r, 2).Value '● 2列/B列 (H1)
targetSheet.Cells(r + 1, i + 2).Value = csvSheet.Cells(r, 3).Value '● 3列/C列 (H2)
'#targetSheet.Cells(r + 1, i + 2).Value = csvSheet.Cells(r, 4).Value '● 4列/D列 (H3)
'#targetSheet.Cells(r + 1, i + 2).Value = csvSheet.Cells(r, 5).Value '● 5列/E列 (H4)
Next r
csvBook.Close SaveChanges:=False
Next i
'#**********************
'#⑥ 列幅の自動調整 (AutoFit)
'#**********************
targetSheet.UsedRange.Columns.AutoFit
'#**********************
'#⑦ ファイル名を指定して保存
'#Excel 97-2003形式(.xls)
'#**********************
currentDate = Format(Date, "yyyyMMdd")
excelFileName = "_" & firstFileName & "_" & currentDate & "_★" & ".xls"
'#**********************
'#【xlExcel8 = 56】
'#(Excel 97-2003 ブック形式)
'#**********************
currentBook.SaveAs Filename:=fso.BuildPath(scriptPath, excelFileName), FileFormat:=56
currentBook.Close SaveChanges:=False
MsgBox "【処理完了】" & vbCrLf & excelFileName, vbInformation
'#**********************
'#【終了処理】
'#（ExitProcedure）
'#**********************
ExitProcedure:
'#**********************
'#画面更新、警告、自動計算を元に戻す
'#**********************
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
'#**********************
'#【エラーハンドリング処理を実行】
'#（ErrorHandler）
'#**********************
ErrorHandler:
MsgBox "【予期せぬエラー発生の為、処理中断】" & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"エラー内容: " & Err.Description, vbCritical
'#**********************
'#【開きっぱなしのCSVや作成中ファイルを閉じる】
'#（必要に応じて実行）
'#**********************
On Error Resume Next
If Not csvBook Is Empty Then csvBook.Close SaveChanges:=False
If Not currentBook Is Empty Then currentBook.Close SaveChanges:=False
'#**********************
'#【終了処理（ExitProcedure）へ移動】
'#**********************
Resume ExitProcedure
End Sub
PR
