仕様:
・ダイアログで入力フォルダを選択
・エクセルファイルのみ処理対象
・出力
エクセルファイルと同名フォルダを作成し、その中にシート名のファイルを作成
また、全シート連結したものを"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 textdata As String
'1 行ずつ読みこんで､特定パターンのデータだけ出力
textdata = ""
With fso.OpenTextFile(outfile, 1)
Do While Not .AtEndOfStream
Dim myarr As Variant
myarr = Split(.ReadLine, vbTab)
Dim myval As String
Dim colnum As Long
colnum = 1
If UBound(myarr) >= colnum Then
myval = myarr(colnum)
If myval Like "*□*" Then
textdata = textdata & myval & vbCrLf
End If
End If
Loop
End With
'一括書き込み
Dim f As Object
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
Dim symbol As String
Select Case j Mod 3
Case 0
symbol = "○"
Case 1
symbol = "△"
Case Else
symbol = "□"
End Select
sh.Cells(j, 1) = symbol & " " & CStr(Int(1000 * Rnd))
sh.Cells(j, 2) = symbol & " " & CStr(Int(1000 * Rnd))
sh.Cells(j, 3) = symbol & " " & CStr(Int(1000 * Rnd))
Next j
Next sheet
'ワークブック保存
wb.SaveAs filepath
'ワークブックを閉じる
wb.Close
End Sub
