https://www.sejuku.net/blog/75132#index_id5
https://vbanobuhinko.com/%E3%83%86%E3%82%AD%E3%82%B9%E3%83%88%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E4%B8%80%E6%8B%AC%E8%AA%AD%E3%81%BF%E8%BE%BC%E3%81%BF%E3%81%99%E3%82%8B/
https://excelwork.info/excel/fsowrite/
http://officetanaka.net/excel/vba/tips/tips39.htm
仕様:
・ダイアログで入力フォルダを選択
・エクセルファイルのみ処理対象
・出力
エクセルファイルと同名フォルダを作成し、その中にシート名のファイルを作成
また、全シート連結したものを"ALL.txt"のファイル名で作成
-- 1. 開発タブの挿入でボタンやチェックボックスを作成
※ActiveXコントロールのものを使用する
-- 2. デザインモードONで作成したボタンをダブルクリックするとエディタが開くので下記コードを記載。デザインモードOFFで実行
Option Explicit
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"
'WORKフォルダがない場合、作成してテストファイル作成
If Dir(strFolderPath, vbDirectory) = "" Then
'WORKフォルダ作成
MkDir strFolderPath
'入力用テストファイル作成
Call createFile(0, strFolderPath & "\File01.xlsx")
Call createFile(1, strFolderPath & "\File02.xlsx")
Call createFile(2, strFolderPath & "\File03.xlsx")
End If
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
strFolderPath = .SelectedItems(1)
End If
End With
Dim file As Object
Dim files As Object
Dim sheet As Object
Dim wb As Workbook
Dim sh As Worksheet
Set files = fso.GetFolder(strFolderPath).files
For Each file In files
Set wb = Workbooks.Open(file)
If wb.Name Like "*.xlsx" Then
'エクセルファイル名のフォルダがない場合、作成
Dim foldername As String
foldername = strFolderPath & "\" & Replace(wb.Name, ".xlsx", "")
If Dir(foldername, vbDirectory) = "" Then
MkDir foldername
End If
'全シート連結ファイル
Dim outfile_all As String
outfile_all = foldername & "\" & "ALL.txt"
'冪等性のため、全シート連結ファイルが存在する場合は削除
If Dir(outfile_all) <> "" Then
Kill outfile_all
End If
For Each sheet In wb.Worksheets
Set sh = sheet
Dim outfile As String
outfile = foldername & "\" & sh.Name & ".txt"
sh.Activate
sh.Copy
ActiveWorkbook.SaveAs Filename:=outfile, FileFormat:=xlText
ActiveWorkbook.Close
'テキストファイル編集
Dim f As Object
Dim textdata As String
'一括読み込み
Set f = fso.OpenTextFile(outfile, 1)
textdata = f.ReadAll
f.Close
'テキスト編集
If CheckBox1.Value = True Then
textdata = Replace(textdata, " ", "")
End If
If CheckBox2.Value = True Then
textdata = Replace(textdata, vbTab, "")
End If
'一括書き込み
Set f = fso.OpenTextFile(outfile, 2)
f.write textdata
f.Close
'全シート連結ファイルの一括書き込み
Set f = fso.OpenTextFile(outfile_all, 8, True)
f.writeline "◇◇◇◇◇◇◇" & sh.Name & "◇◇◇◇◇◇◇"
f.write textdata
f.Close
ThisWorkbook.Activate
Next sheet
End If
wb.Close
Next file
MsgBox "処理完了"
'確認メッセージを表示する
Application.DisplayAlerts = True
'画面を更新する
Application.ScreenUpdating = True
End Sub
'ファイル作成関数
Private Sub createFile(addsheetnum As Long, filepath As String)
Dim i As Long
Dim j As Long
'ワークブック作成
Dim wb As Workbook
Set wb = Workbooks.Add
'シート名取得
Dim sheetName As String
sheetName = Worksheets(1).Name
'シート名変更
Worksheets(1).Name = "シート1"
'シート追加
Dim sh As Worksheet
i = 0
Do While i < addsheetnum
Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh.Name = "シート" & (Worksheets.Count)
i = i + 1
Loop
Dim sheet As Variant
For Each sheet In wb.Worksheets
Set sh = sheet
j = 0
For j = 1 To 30
sh.Cells(j, 1) = CStr(Int(1000 * Rnd)) & " " & CStr(Int(1000 * Rnd))
sh.Cells(j, 2) = CStr(Int(1000 * Rnd)) & " " & CStr(Int(1000 * Rnd))
sh.Cells(j, 3) = CStr(Int(1000 * Rnd)) & " " & CStr(Int(1000 * Rnd))
Next j
Next sheet
'ワークブック保存
wb.SaveAs filepath
'ワークブックを閉じる
wb.Close
End Sub
