https://daitaideit.com/vba-convert-csv-to-excel/
https://hironimo.com/prog/excel/vba-sheet-copy-book/
仕様:
フォルダ→ファイル名、ファイル→シート名 でエクセルファイル作成
①テキストを一括読込してtab -> カンマ置換
②csvファイルをxlsxファイルとして保存
③ワークブックを一つのワークブックにマージ
-- 1. 開発タブの挿入でボタンを作成
※ActiveXコントロールのものを使用する
-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行
Option Explicit
Dim i As Long
Private Sub CommandButton1_Click()
'画面を更新しない
Application.ScreenUpdating = False
'確認メッセージを表示しない
Application.DisplayAlerts = False
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strFolderPath As String
strFolderPath = ThisWorkbook.path & "\WORK"
If Dir(strFolderPath, vbDirectory) = "" Then
'テストフォルダ作成
MkDir strFolderPath
MkDir strFolderPath & "\Dir01"
MkDir strFolderPath & "\Dir02"
MkDir strFolderPath & "\Dir03"
'テストファイル作成
Call createTextFile(strFolderPath & "\Dir01\file0101.txt")
Call createTextFile(strFolderPath & "\Dir01\file0102.txt")
Call createTextFile(strFolderPath & "\Dir01\file0103.txt")
Call createTextFile(strFolderPath & "\Dir02\file0201.txt")
Call createTextFile(strFolderPath & "\Dir02\file0202.txt")
Call createTextFile(strFolderPath & "\Dir02\file0203.txt")
Call createTextFile(strFolderPath & "\Dir03\file0301.txt")
End If
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
strFolderPath = .SelectedItems(1)
End If
End With
Dim folders As Object
Dim folder As Object
Set folders = fso.GetFolder(strFolderPath)
'サブフォルダの一覧を取得
For Each folder In folders.SubFolders
'統合ワークブック作成
Dim outfile3 As String
outfile3 = folder.path & ".xlsx"
Dim wb3 As Workbook
Set wb3 = Workbooks.Add
'サブフォルダ内にあるテキストファイル取得
Dim file As Object
Dim files As Object
Set files = fso.GetFolder(strFolderPath & "\" & folder.Name).files
For Each file In files
If file.Name Like "*.txt" Then
'一括読み込み
Dim f As Object
Dim textdata As String
Set f = fso.OpenTextFile(file.path, 1)
textdata = f.ReadAll
textdata = Replace(textdata, vbTab, ",")
f.Close
'一括書き込み
Dim outfile As String
outfile = Replace(file.path, ".txt", ".csv")
Set f = fso.OpenTextFile(outfile, 2, True)
f.write textdata
f.Close
'単独ワークブック作成
Dim outfile2 As String
outfile2 = Replace(file.path, ".txt", ".xlsx")
Dim wb2 As Workbook
Set wb2 = Workbooks.Open(outfile)
wb2.SaveAs outfile2, xlOpenXMLWorkbook
'単独ワークブックを統合ワークブックへコピー
wb2.Worksheets(1).Copy After:=wb3.Worksheets(wb3.Worksheets.Count)
Dim sh3 As Worksheet
Set sh3 = wb3.Worksheets(wb3.Worksheets.Count)
sh3.Name = Replace(file.Name, ".txt", "")
wb2.Close
'中間ファイルは削除
Kill outfile
Kill outfile2
End If
Next file
'先頭のシートは削除
wb3.Worksheets(1).Delete
wb3.Close True, outfile3
Next folder
MsgBox "処理完了"
'確認メッセージを表示する
Application.DisplayAlerts = True
'画面を更新する
Application.ScreenUpdating = True
End Sub
'ファイル作成関数
Private Sub createTextFile(filepath As String)
Open filepath For Output As #1
Print #1, "111" & vbTab & "222" & vbTab & "333"
Print #1, "AAA" & vbTab & "BBB" & vbTab & "CCC"
Print #1, "XXX" & vbTab & "YYY" & vbTab & "ZZZ"
Close #1
End Sub
