(1)シートのレイアウト
Option Explicit
'◇◇◇ 【事前準備】シートレイアウト自動生成マクロ ◇◇◇
'
'Excelブックを新規作成し、Sheet1にActiveXコントロールのボタンを配置。
'そのボタンをダブルクリックして、Visual Basic Editorにこのソースを貼り付ける。
'シートが完成したらこのソースは不要。
Private Sub CommandButton1_Click()
'◇ シート設定
Dim curSheet As Worksheet
Set curSheet = Sheet1
curSheet.Name = "メイン"
curSheet.Tab.Color = RGB(&HFF, &HFF, &H0)
'◇ 見出し
Columns("A").ColumnWidth = 4
Range("B2").Select
Selection.Value = "タイトル：○○処理"
Selection.Font.Bold = True
Columns("B:C").ColumnWidth = 40
'◇ 処理対象フォルダ
Range("B4").Select
Selection.Value = "対象フォルダ"
Call drawWaku
Call paintMidashi
Range("B5").Select
ActiveWorkbook.Names.Add Name:="対象フォルダ", RefersTo:="=メイン!$B$5"
Selection.Value = "C:\work\"
Call drawWaku
Rows("6").RowHeight = 25
'◇ 出力ファイル名
Range("B7").Select
Selection.Value = "出力ファイル名"
Call drawWaku
Call paintMidashi
Range("B8").Select
ActiveWorkbook.Names.Add Name:="出力ファイル名", RefersTo:="=メイン!$B$8"
Selection.Value = "Export.csv"
Call drawWaku
Rows("9").RowHeight = 25
'◇ ヘッダ制御
Range("B10").Select
Selection.Value = "ヘッダ制御"
Call drawWaku
Call paintMidashi
Range("B11").Select
Call drawWaku
Rows("11").RowHeight = 20
Range("B12").Value = "(1) 冒頭１ファイルのヘッダ行を保持する。"
Range("B13").Value = "(2) 外部ファイルからヘッダ行を付加する。"
Range("B14").Value = "(3) ヘッダ行の制御をしない。"
Rows("12:14").RowHeight = 0
'◇ 外部ヘッダファイル名
Range("B15").Select
Selection.Value = "外部ヘッダファイル名"
Call drawWaku
Call paintMidashi
Range("B16").Select
ActiveWorkbook.Names.Add Name:="外部ヘッダファイル名", RefersTo:="=メイン!$B$16"
Selection.Value = "HEADER.txt"
Call drawWaku
Rows("17").RowHeight = 25
'◇ ファイル名カラム追加制御
Range("B18").Select
Selection.Value = "ファイル名カラム追加制御"
Call drawWaku
Call paintMidashi
Range("B19").Select
Call drawWaku
Rows("19").RowHeight = 20
Rows("20").RowHeight = 25
'◇ 処理結果
Range("B21:C21").Select
Selection.Value = "処理結果"
Call drawWaku
Call paintMidashi
Range("B22:C26").Select
Call drawWaku
Range("B22").Value = "対象ファイル数"
Range("B23").Value = "処理済ファイル数"
Range("B24").Value = "進捗率"
Range("B25").Value = "総レコード数"
Range("B26").Value = "ファイルサイズ"
ActiveWorkbook.Names.Add Name:="処理結果", RefersTo:="=メイン!$C$22:$C$26"
Range("C24").NumberFormatLocal = "0.0%"
'◇ 実行ボタン作成
With curSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Left:=300, Top:=50, Width:=100, Height:=40)
.Name = "Btn_Exec"
.Object.Caption = "実行"
.Object.Font.Size = 12
End With
'作ったコントロールを後から変更する場合
'シェイプの書式設定を変える
curSheet.Shapes("Btn_Exec").Top = 40
'オブジェクトのプロパティを変える
curSheet.OLEObjects("Btn_Exec").Object.Font.Size = 16
'◇ プルダウンリスト
With curSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Left:=Range("B11").Left + 2, Top:=Range("B11").Top + 1, Width:=210, Height:=18)
.Name = "Cmb_HeaderManipulate"
.Object.Style = fmStyleDropDownList
'※.Object.AddItemで追加してもファイルに保存されない
.ListFillRange = "メイン!$B$12:$B$14"
.Object.ListIndex = 2
End With
'◇ ファイル名カラム付加チェックボックス
With curSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Left:=Range("B19").Left + 4, Top:=Range("B19").Top + 1, Width:=200, Height:=18)
.Name = "Chk_WithFileName"
.Object.Caption = "最後尾カラムにファイル名を付加する"
.Object.Value = True
End With
'◇ 不要ボタン削除
curSheet.Shapes.Range("CommandButton1").Select
Selection.Delete
'カーソルを先頭へ
Range("A1").Select
End Sub
'セルの枠描画
Private Sub drawWaku()
Selection.Borders(xlLeft).LineStyle = xlSolid
Selection.Borders(xlRight).LineStyle = xlSolid
Selection.Borders(xlTop).LineStyle = xlSolid
Selection.Borders(xlBottom).LineStyle = xlSolid
End Sub
'見出しセル背景色
Private Sub paintMidashi()
With Selection.Interior
.Pattern = xlSolid
.Color = RGB(&HFF, &HCC, &H99)
End With
End Sub
(2)CSVマージ処理 サブルーチン
Option Explicit
'
'◇◇◇ 【メイン処理】CSVマージ処理 ◇◇◇
'
Private Sub Btn_Exec_Click()
'変数宣言
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim curFolder As Object
Dim curFiles As Object
Dim curFile As Object
Dim tsInputStr As Object
Dim tsOutputStr As Object
'「Microsoft Scripting Runtime」を参照設定している場合
' Dim fso As New FileSystemObject
' Dim curFolder As Folder
' Dim curFiles As Files
' Dim curFile As File
' Dim tsInputStr As TextStream
' Dim tsOutputStr As TextStream
Dim strFolderName As String
Dim strOutputFileName As String
Dim strAddHdFileName As String
Dim strCurLine As String
Dim rngResult As Range
Dim lngFileCnt As Long
Dim lngTotalFileNum As Long
Dim lngTotalLineCnt As Long
Dim lngCurFileLineCnt As Long
'定数
Const WQ As String = """" 'ダブルクオート
Const FileNameHdCol As String = ",ファイル名"
'ワークブック、シート特定
Dim myWorkBook As Workbook
Dim myWorkSeet As Worksheet
Set myWorkBook = ActiveWorkbook
Set myWorkSeet = myWorkBook.Sheets("メイン")
'ヘッダ制御
Dim intHdMpl As Integer
'ヘッダ制御区分 定数
'(1) 冒頭１ファイルのヘッダ行を保持する。２個目以降のファイルは１行目を削除。
' （元のCSVファイルすべてにヘッダ行が付いている場合を想定）
Const hmOriginal As Integer = 0
'(2) 外部ファイルからヘッダ行を付加する。（元のCSVファイルすべてにヘッダ行がない場合を想定）
Const hmOutsource As Integer = 1
'(3) ヘッダ行の制御をしない（単純にCSVをマージ）
Const hmNone As Integer = 2
On Error GoTo ErrorHandler
'◇◇◇ 取込前準備 ◇◇◇
'対象フォルダ
strFolderName = myWorkSeet.Range("対象フォルダ")
'出力ファイル名
strOutputFileName = myWorkSeet.Range("出力ファイル名")
'外部ヘッダファイル名
strAddHdFileName = myWorkSeet.Range("外部ヘッダファイル名")
'処理結果
Set rngResult = myWorkSeet.Range("処理結果")
'処理結果欄の初期化
rngResult.Cells(1, 1).Value = ""
rngResult.Cells(2, 1).Value = ""
rngResult.Cells(3, 1).Value = ""
rngResult.Cells(4, 1).Value = ""
rngResult.Cells(5, 1).Value = ""
'設定値取得失敗
If strFolderName = "" Or strOutputFileName = "" Then
MsgBox "対象フォルダ、または出力ファイル名が指定されていません。", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
'対象フォルダ取得失敗
If Not fso.FolderExists(strFolderName) Then
MsgBox "対象フォルダが存在しません。", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
'対象フォルダ取得
Set curFolder = fso.GetFolder(strFolderName)
'ファイル一覧取得
Set curFiles = curFolder.Files
'ファイル取得失敗
If curFiles.Count = 0 Then
MsgBox "対象フォルダ内にファイルが存在しません。", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
'対象ファイル数事前カウント
For Each curFile In curFiles
If CheckFileName(curFile.Name) Then
lngFileCnt = lngFileCnt + 1
End If
'対象ファイル数表示
rngResult.Cells(1, 1).Value = CStr(lngFileCnt)
Next
lngTotalFileNum = lngFileCnt
lngFileCnt = 0
'対象ファイルなし
If lngTotalFileNum = 0 Then
MsgBox "対象フォルダ内に処理対象ファイルが存在しません。", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
'ヘッダ制御区分をプルダウンより取得
intHdMpl = Cmb_HeaderManipulate.ListIndex
'外部ヘッダファイル存在チェック
If intHdMpl = hmOutsource Then
If Not fso.FileExists(strFolderName & "\" & strAddHdFileName) Then
MsgBox "対象フォルダ内に外部ヘッダファイルが存在しません。", vbOKOnly + vbExclamation, "警告"
Exit Sub
End If
End If
'実行前確認
If vbNo = MsgBox("処理を実行しますか？", vbYesNo + vbQuestion, "確認") Then Exit Sub
'コントロールロック
Chk_WithFileName.Enabled = False
Cmb_HeaderManipulate.Enabled = False
'◇◇◇ ファイル出力開始 ◇◇◇
'出力ファイルを開く
Set tsOutputStr = fso.CreateTextFile(Filename:=strFolderName & "\" & strOutputFileName, Overwrite:=True)
'外部ファイルからヘッダ行を取得
If intHdMpl = hmOutsource Then
'入力ファイル（外部ヘッダファイル）を開く
Set tsInputStr = fso.OpenTextFile(strFolderName & "\" & strAddHdFileName)
strCurLine = tsInputStr.ReadLine
If Chk_WithFileName.Value Then
'ファイル名カラムヘッダ
strCurLine = strCurLine & FileNameHdCol
End If
'ヘッダー行出力
tsOutputStr.WriteLine strCurLine
'入力ファイル（外部ヘッダファイル）を閉じる
tsInputStr.Close
Set tsInputStr = Nothing
End If
'総行数カウンタ初期化
lngTotalLineCnt = 0
'フォルダ内ファイル操作処理開始
For Each curFile In curFiles
'ファイル名チェック（不要ファイル除外）
If Not CheckFileName(curFile.Name) Then GoTo EndFileLoop
'入力ファイルを開く（CSV）
Set tsInputStr = fso.OpenTextFile(strFolderName & "\" & curFile.Name)
'ファイル数インクリメント
lngFileCnt = lngFileCnt + 1
'現在ファイル 行数カウンタ初期化
lngCurFileLineCnt = 0
'CSVファイルの入出力
Do Until tsInputStr.AtEndOfLine
'１行読み込む
strCurLine = tsInputStr.ReadLine
'ファイル名カラム有無制御
If Chk_WithFileName.Value Then
If intHdMpl = hmOriginal And lngTotalLineCnt = 0 Then
'最初の１ファイルの１行目
'ファイル名カラムヘッダ追加
strCurLine = strCurLine & FileNameHdCol
Else
'ファイル名カラム追加
strCurLine = strCurLine & "," & WQ & curFile.Name & WQ
End If
End If
If intHdMpl = hmOriginal And lngTotalLineCnt <> 0 And lngCurFileLineCnt = 0 Then
'ファイル２個目以降で、ヘッダ行を出力しない場合
Else
'それ以外は行をファイルへ出力
tsOutputStr.WriteLine strCurLine
End If
'行数インクリメント
lngTotalLineCnt = lngTotalLineCnt + 1
lngCurFileLineCnt = lngCurFileLineCnt + 1
Loop
'◇ 進捗状況表示
'処理済ファイル数
rngResult.Cells(2, 1).Value = CStr(lngFileCnt)
'進捗率
rngResult.Cells(3, 1).Value = CDbl(lngFileCnt) / lngTotalFileNum
DoEvents
'入力CSVファイルを閉じる
tsInputStr.Close
Set tsInputStr = Nothing
EndFileLoop:
Next
'◇◇◇ 終了処理 ◇◇◇
'出力ファイルを閉じる
tsOutputStr.Close
Set tsOutputStr = Nothing
'◇ 処理結果表示
'処理済ファイル数
rngResult.Cells(2, 1).Value = CStr(lngFileCnt)
'進捗率
rngResult.Cells(3, 1).Value = "完了"
'総レコード数
rngResult.Cells(4, 1).Value = CStr(lngTotalLineCnt)
'ファイルサイズ
rngResult.Cells(5, 1).Value = CStr(fso.GetFile(strFolderName & "\" & strOutputFileName).Size)
'FileSystemObjectを閉じる
Set fso = Nothing
'完了メッセージ
MsgBox "出力が完了しました。", vbOKOnly + vbInformation, "情報"
'コントロールアンロック
Chk_WithFileName.Enabled = True
Cmb_HeaderManipulate.Enabled = True
'終了
Exit Sub
ErrorHandler:
MsgBox "エラーが発生しました。処理を中断します。" & vbNewLine & _
Err.Number & ":" & Err.Description, vbExclamation, "エラー"
Chk_WithFileName.Enabled = True
Cmb_HeaderManipulate.Enabled = True
End
End Sub
'ファイル名命名規則チェック関数
'※この関数は取り込むファイル名に合わせて適宜改修します。
Private Function CheckFileName(ByVal argName As String) As Boolean
'ファイル名（例）ABCFILE_20170715112545.csv
Const PREFIX As String = "ABCFILE_"
Const SUFFIX As String = ".csv"
Const NUMLEN As Integer = 14
CheckFileName = False
If Not (Mid(argName, 1, Len(PREFIX)) = PREFIX) Then Exit Function
If Not (Mid(argName, Len(PREFIX) + 1, NUMLEN) Like String(NUMLEN, "#")) Then Exit Function
If Not Mid(argName, Len(PREFIX) + NUMLEN + 1, Len(SUFFIX)) = SUFFIX Then Exit Function
CheckFileName = True
End Function
