ここで紹介するVBAは、CSVファイルやエクセルファイルの中の全てのシートを、このマクロが実行されるエクセルファイルにシートごとにコピーして一つにまとめるマクロです。
最初にSheet1のセルB1に、ワイルドカードを使って複数のファイルを指定するパスを書き込んでおきます。
拡張子で処理を分けています。
対応している拡張子は、CSVファイルが.csvと.txtで、エクセルファイルは.xlsと.xlsxです。
こちらもどうぞ。
複数のファイルを一つのエクセルシートにするVBA
Option Explicit
'
'複数のCSVファイルのテキストファイル、またはエクセルファイルを
'このマクロのあるエクセルファイルにまとめるVBAです。
'複数のファイルの指定はSheet1のセルB1にワイルドカードを使用して
'指定する。
Public Sub addFile()
'検索するファイルのパス
Dim strPath As String
'ファイル名が入る変数
Dim f As String
'複数のファイルを指定したワイルドカード使用のパスを取得
'事前にSheet1のB1のセルに絶対パスで指定しておきます。
'例 D:\Testa\*.xlsx
'例 D:\Testa\*.csv
strPath = ThisWorkbook.Worksheets("Sheet1").Range("B1").Value
'指定されたパスのファイルを取得する。
f = Dir(strPath, vbNormal)
Do While f <> ""
Dim strExt As String
Dim pos As Integer
Dim addedSheet As Worksheet
'Dir関数ではファイル名だけなので、親フォルダのパスを付け加える
f = Left(strPath, InStrRev(strPath, "\")) & f
'テキストファイル用のデータをコピーするシートを付け加えておく
Set addedSheet = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
'ファイルの拡張子の位置を取得
pos = InStrRev(f, ".")
'拡張子を小文字にして取得
strExt = LCase(Mid(f, pos + 1))
'拡張子で処理を分ける
Select Case strExt
'テキストファイルで、中身はCSVのファイルを想定
Case "txt"
readCSVFile addedSheet, f
'CSVファイルを想定
Case "csv"
readCSVFile addedSheet, f
'拡張子がxlsのエクセルファイルを想定
Case "xls"
'エラー表示をさせない
Application.DisplayAlerts = False
'先ほど追加したシートを削除
addedSheet.Delete
'エラー表示を戻す
Application.DisplayAlerts = True
'エクセルファイルのシートをこのファイルへコピーする関数
readXLSFile f
Case "xlsx"
'エラー表示をさせない
Application.DisplayAlerts = False
'先ほど追加したシートを削除
addedSheet.Delete
'エラー表示を戻す
Application.DisplayAlerts = True
'エクセルファイルのシートをこのファイルへコピーする関数
readXLSFile f
End Select
Set addedSheet = Nothing
'次のファイル名を取得する
f = Dir()
Loop
Set addedSheet = Nothing
End Sub
'エクセルファイルの中のシートを全てコピーする関数
Private Sub readXLSFile(ByVal strFilePath)
Dim wb As Workbook
Dim s As Worksheet
'開いたエクセルファイルを開いて、シートをコピーするためにインスタンスを取得する
Set wb = Workbooks.Open(strFilePath)
'すべてのシートでループする
For Each s In wb.Worksheets
'このファイルへシートを最後にコピーする
s.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next s
wb.Close
Set wb = Nothing
End Sub
'CSVファイルをこのエクセルファイルにコピーするための関数
Private Sub readCSVFile(ByRef addedSheet As Worksheet, ByVal strFilePath)
'CSVファイルを読み込む
analyseCSV addedSheet, strFilePath, ""
End Sub
'CSVファイルをコピーするメインの処理用関数
Private Sub analyseCSV(ByVal addedSheet As Worksheet, ByVal fileName As String, ByVal quote As String)
Dim fileNum As Integer
Dim buf As String
'カンマでスプリットした後の配列
Dim arrLineData() As String
Dim strSplit As String
'ワークシートの行番号
Dim row As Integer
Dim i As Integer
'クォートの長さ
Dim length As Integer
If fileName = "" Then
Exit Sub
End If
With addedSheet
'クォーテーションの長さを取得しておく(汎用のため)
length = Len(quote)
strSplit = quote & "," & quote
'ワークシートの行の番号
row = 1
'空いているファイル番号を取得
fileNum = FreeFile
Open fileName For Input As #fileNum
Do Until EOF(fileNum)
Line Input #fileNum, buf
'行の最初と最後の囲み文字を削除する処理
buf = Left(buf, Len(buf) - length)
buf = Right(buf, Len(buf) - length)
'1行のデータを各項目に分解する処理
arrLineData = Split(buf, strSplit)
'何かの処理をしたい場合はここで処理を書き込む
'do something
'ワークシートのセルに書き込む
For i = 0 To UBound(arrLineData)
If quote = """" Then
arrLineData(i) = Replace(arrLineData(i), """""", """")
End If
.Cells(row, i + 1) = arrLineData(i)
Next i
'ワークシートの行番号をカウントアップする
row = row + 1
Loop
Close #fileNum
End With
End Sub
