エクセルマクロで複数あるCSVファイルを、１つのエクセルファイルに貼りつけるマクロについて記事を書いておきます。普段は機械設計や3DCADについての記事を書いておりますが、実際の設計現場では実験や評価をすることもあり、その結果をエクセルまとめてグラフ化するなどの作業などもあります。
また実験評価の結果データなどはCSVファイルでエクスポートすることが多く、それらをまとめてエクセルファイルに追加するという業務がありますが、毎回データを入力するのが大変なのでエクセルマクロを使用して時間短縮をするとかなり便利になります。
今回はそのマクロの一例を記事として残しておきます。ソースコードもコピペできるようにしておくので、何かの参考していていただければ幸いです。
新田設計今回はエクセルを使ったマクロについて、一例のソースコードを書いておきます。
正直自分用にもコピペで使えるのでコードを残しておきたかった笑
目次
複数のCSVファイルを１つに貼りつけるマクロ
実際のマクロコード（マクロファイルに貼りつけ）
※右側にあるVBAの下にマウスカーソルを合わせると、アイコンから全コピーすることが可能です
Sub CSVファイルを１つに貼りつけるマクロ()
Dim ws As Worksheet
Dim folderPath As String
Dim fileName As String
Dim lastRow As Long
Dim lastCol As Long
Dim dataRange As Range
Dim firstFile As Boolean
Dim fd As FileDialog
Dim fileCount As Integer
Dim defaultFolder As String
' 画面更新をオフ（※チカチカ防止）
Application.ScreenUpdating = False
' デスクトップのパスを取得
defaultFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' フォルダ選択ダイアログを表示（※デフォルトをデスクトップにする）
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "CSVファイルが入っているフォルダを選択してください"
.InitialFileName = defaultFolder
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub ' キャンセルされたら終了
folderPath = .SelectedItems(1) & "\"
End With
Set fd = Nothing
' フォルダ内のCSVファイルを取得
fileName = Dir(folderPath & "*.csv")
' CSVが1つもない場合、エラーメッセージを表示して終了
If fileName = "" Then
MsgBox "指定したフォルダにCSVファイルが見つかりませんでした", vbExclamation, "エラー"
Application.ScreenUpdating = True ' 画面更新を元に戻す
Exit Sub
End If
' マクロを実行するシートを設定
Set ws = ThisWorkbook.Sheets(1)
ws.Cells.Clear ' シートをクリア
firstFile = True
fileCount = 0
' ファイルがある限りループ
Do While fileName <> ""
Dim tempWb As Workbook
Dim tempWs As Worksheet
Set tempWb = Workbooks.Open(folderPath & fileName)
Set tempWs = tempWb.Sheets(1)
' データ範囲を取得（UsedRangeを使い、空白行があっても全データを取得）
With tempWs
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Set dataRange = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
End With
' ヘッダー行の処理
If firstFile Then
' 最初のファイルはヘッダーごとコピー
ws.Range("A1").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value
firstFile = False
Else
' 2つ目以降はヘッダーを除いてコピー
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
dataRange.Offset(1, 0).Resize(dataRange.Rows.Count - 1, dataRange.Columns.Count).Copy
ws.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues
End If
' CSVを閉じる（保存せず）
tempWb.Close False
fileCount = fileCount + 1
fileName = Dir() ' 次のファイルへ
Loop
' 選択解除 & A1セルに戻る
Application.CutCopyMode = False
ws.Activate
ws.Range("A1").Select
' 画面更新を元に戻す
Application.ScreenUpdating = True
' 統合完了メッセージ
MsgBox "CSVファイルの統合が完了しました" & vbCrLf & "統合したファイル数: " & fileCount, vbInformation, "完了"
End Subマクロコードの貼りつけ
[開発] タブの [Visual Basic] をクリックします
[挿入] の [標準モジュール] をクリックします
コピーしたマクロのコードを貼りつけます
エクセルの画面に戻り [マクロ] をクリックします
マクロを選択して [実行] をクリックします
CSVが保存されているフォルダを選択してOKをクリックします
フォルダ内にあるCSVファイルの中身が、マクロを実行したエクセルに貼りつけられました
もしCSVファイルがない場合は、下図のようなエラー画面になります
上記のコードでエクセルファイルを新規作成するマクロ
新田設計マクロを動かすエクセルと、結合したCSVファイルを別々で保存したいバージョンのソースコードも書いておきます。
結合方法などはどちらも同じです。
実際のマクロコード（新規ファイルを作成バージョン）
Sub CSVファイルを１つに貼りつけて新しいファイルを新規作成()
Dim newWb As Workbook
Dim ws As Worksheet
Dim folderPath As String
Dim fileName As String
Dim lastRow As Long
Dim lastCol As Long
Dim dataRange As Range
Dim firstFile As Boolean
Dim fd As FileDialog
Dim fileCount As Integer
Dim defaultFolder As String
' 画面更新をオフ（※チカチカ防止）
Application.ScreenUpdating = False
' デスクトップのパスを取得
defaultFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' フォルダ選択ダイアログを表示（※デフォルトをデスクトップにする）
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "CSVファイルが入っているフォルダを選択してください"
.InitialFileName = defaultFolder
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub ' キャンセルされたら終了
folderPath = .SelectedItems(1) & "\"
End With
' フォルダ内のCSVファイルを取得
fileName = Dir(folderPath & "*.csv")
' CSVが1つもない場合、エラーメッセージを表示して終了
If fileName = "" Then
MsgBox "指定したフォルダにCSVファイルが見つかりませんでした", vbExclamation, "エラー"
Application.ScreenUpdating = True
Exit Sub
End If
' 新しいExcelファイルを作成
Set newWb = Workbooks.Add
Set ws = newWb.Sheets(1)
firstFile = True
fileCount = 0
' ファイルがある限りループ
Do While fileName <> ""
Dim tempWb As Workbook
Dim tempWs As Worksheet
Set tempWb = Workbooks.Open(folderPath & fileName)
Set tempWs = tempWb.Sheets(1)
' データ範囲を取得
With tempWs
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Set dataRange = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
End With
' ヘッダー行の処理
If firstFile Then
' 最初のファイルはヘッダーごとコピー
ws.Range("A1").Resize(dataRange.Rows.Count, dataRange.Columns.Count).Value = dataRange.Value
firstFile = False
Else
' 2つ目以降はヘッダーを除いてコピー
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
dataRange.Offset(1, 0).Resize(dataRange.Rows.Count - 1, dataRange.Columns.Count).Copy
ws.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues
End If
' CSVを閉じる（保存せず）
tempWb.Close False
fileCount = fileCount + 1
fileName = Dir() ' 次のファイルへ
' クリップボードの選択解除
Application.CutCopyMode = False
Loop
' A1セルに戻る
ws.Range("A1").Select
' 画面更新を元に戻す
Application.ScreenUpdating = True
' 保存ダイアログを表示
Dim savePath As String
savePath = Application.GetSaveAsFilename(InitialFileName:="統合データ.xlsx", FileFilter:="Excelファイル (*.xlsx), *.xlsx")
If savePath <> "False" Then
newWb.SaveAs savePath, FileFormat:=xlOpenXMLWorkbook
MsgBox "CSVファイルの統合が完了しました。" & vbCrLf & "統合したファイル数: " & fileCount & vbCrLf & "保存先: " & savePath, vbInformation, "完了"
Else
MsgBox "統合したデータは保存されませんでした", vbExclamation, "キャンセル"
End If
End SubCSV結合したエクセルファイルを好きな場所に新規保存します
おわりに
今回はエクセルを使用したマクロについて記事を書いておきました。
実際の設計業界ではエクセルを使用しての資料作成業務が結構あるため、今後も便利だと思ったマクロについてはホームページに記載していく予定ですので、気になる方はブックマークしていただければと思います。
また機械設計や3DCADに関する内容やなどは、X（旧：Twitter）にもアップしていきますので、もし気になる方はX（旧：Twitter）のフォローもしていただけると嬉しいです。
