元データをひな形に転記して、サブフォルダ内に別ファイル名として保存する
プログラムの運用中、複数のデ一タを抽出して雛形に書出し、名前を変えて保存をすることがあったのだが、いかんせん量が多く面倒だったのでExcelVBAによるマクロツ一ルを作成したので情報共有する。
ソースコード
ソースコードは下記の通り
Sub Copy_to_template()
'----------------------------------------------
'概要:元データをひな形に転記して、サブフォルダ内に別ファイル名として保存する
'機能名:Copy_to_template
'引数:なし
'戻り値:なし
'備考:元データをひな形に転記して、サブフォルダ内に別ファイル名として保存する
'----------------------------------------------
Dim myPath As String
Dim kakutyoshi As String
Dim inputBook_name As String
Dim templateBook_Path As String
Dim templateBook_name As String
Dim outputBook_name As String
Dim mySheet_name As String
Dim InputSubFolder_name As String
Dim OutputSubFolder_name As String
Dim first_row As Integer
Dim first_column As Integer
Dim last_row As Integer
Dim last_column As Integer
Dim column_number As Integer
Dim row_number As Integer
Dim index_flg As Integer
Dim readsubfolder_index_flg As Integer
Dim writesubfolder_index_flg As Integer
Dim row_hosei As Integer
Dim column_hosei As Integer
'-------------------------引数が多いのでエクセルシートに記載する引数の説明--------------------
' 1行目：読込データ対象パス
' 2行目：読込データ拡張子
' 3行目：ひな形ファイルパス
' 4行目：ひな形ファイル名
' 5行目：ひな形ファイル拡張子
' 6行目：ひな形対象シート名
' 7行目：書込ファイル名(通番前)
' 8行目：書込ファイル通番有無
' 9行目：書込ファイル名(通番後ろ1)
'10行目：書込ファイル名(拡張子)
'11行目：読込ファイル通番部分前最終文字
'12行目：読込ファイル通番部分後最終文字
'13行目：読込開始行
'14行目：読込開始列
'15行目：読込終了行
'16行目：読込終了列
'17行目：書込行補正
'18行目：書込列補正
'19行目：読込ファイル移動サブフォルダ名(通番前)
'20行目：読込ファイルサブフォルダ通番有無
'21行目：読込ファイル移動サブフォルダ名(通番後)
'22行目：読込サブフォルダ通番部分前最終文字
'23行目：読込サブフォルダ通番部分後最終文字
'24行目：書込ファイル保存サブフォルダ名(通番前)
'25行目：書込ファイルサブフォルダ通番有無
'26行目：書込ファイル保存サブフォルダ名(通番後)
'27行目：書込サブフォルダ通番部分前最終文字
'28行目：書込サブフォルダ通番部分後最終文字
'-----------------------------------------------------------------------------------------------------
myPath = ThisWorkbook.Worksheets(1).Cells(1, 2).Value & "\"
kakutyoshi = ThisWorkbook.Worksheets(1).Cells(2, 2).Value
templateBook_Path = ThisWorkbook.Worksheets(1).Cells(3, 2).Value & "\"
templateBook_name = ThisWorkbook.Worksheets(1).Cells(4, 2).Value & "." & ThisWorkbook.Worksheets(1).Cells(5, 2).Value
templateSheet_name = ThisWorkbook.Worksheets(1).Cells(6, 2).Value
index_flg = ThisWorkbook.Worksheets(1).Cells(8, 2).Value
row_hosei = ThisWorkbook.Worksheets(1).Cells(17, 2).Value
column_hosei = ThisWorkbook.Worksheets(1).Cells(18, 2).Value
readsubfolder_index_flg = ThisWorkbook.Worksheets(1).Cells(20, 2).Value
writesubfolder_index_flg = ThisWorkbook.Worksheets(1).Cells(25, 2).Value
'拡張子に値が設定されていなかったらデフォルトでcsvをセット
If kakutyoshi = "" Then
kakutyoshi = "csv"
End If
'パス配下の設定した拡張子の最初のファイル名を返す
inputBook_name = Dir(myPath & "*" & kakutyoshi)
'Dir関数がファイル名を返さなくなるまで繰り返す
Do Until inputBook_name = ""
'書込み先のファイル名を作成する
If index_flg = 1 And ThisWorkbook.Worksheets(1).Cells(11, 2).Value <> "" And ThisWorkbook.Worksheets(1).Cells(12,2 ).Value <> "" Then
If ThisWorkbook.Worksheets(1).Cells(11, 3).Value <> "" And ThisWorkbook.Worksheets(1).Cells(12, 3).Value <> "" Then
outputBook_name =ThisWorkbook.Worksheets(1).Cells(7, 2).Value & ExtractString(inputBook_name, ThisWorkbook.Worksheets(1).Cells(11, 2).Value, ThisWorkbook.Worksheets(1).Cells(12, 2).Value) & ThisWorkbook.Worksheets(1).Cells(9, 2).Value & ExtractString(inputBook_name,ThisWorkbook.Worksheets(1).Cells(11, 3).Value, ThisWorkbook.Worksheets(1).Cells(12, 3).Value) & ThisWorkbook.Worksheets(1).Cells(9, 3).Value & "." & ThisWorkbook.Worksheets(1).Cells(10, 2).Value
Else
outputBook_name =ThisWorkbook.Worksheets(1).Cells(7, 2).Value & ExtractString(inputBook_name, ThisWorkbook.Worksheets(1).Cells(11, 2).Value, ThisWorkbook.Worksheets(1).Cells(12, 2).Value) & ThisWorkbook.Worksheets(1).Cells(9, 2).Value & "." & ThisWorkbook.Worksheets(1).Cells(10, 2).Value
End If
Else
outputBook_name =ThisWorkbook.Worksheets(1).Cells(7, 2).Value & "." & ThisWorkbook.Worksheets(1).Cells(10, 2).Value
End If
'読込ファイルの移動先サブフォルダ名を作成する
If readsubfolder_index_flg = 1 And ThisWorkbook.Worksheets(1).Cells(22, 2).Value <> "" And ThisWorkbook.Worksheets(1).Cells(23,2).Value <> "" Then
InputSubFolder_name = "\" & ThisWorkbook.Worksheets(1).Cells(19, 2).Value & ExtractString(inputBook_name, ThisWorkbook.Worksheets(1).Cells(22, 2).Value, ThisWorkbook.Worksheets(1).Cells(23, 2).Value) & ThisWorkbook.Worksheets(1).Cells(21, 2).Value &"\"
Else
InputSubFolder_name = "\" & ThisWorkbook.Worksheets(1).Cells(19, 2).Value & "\"
End If
'書込ファイルの移動先サブフォルダ名を作成する
If writesubfolder_index_flg = 1 And ThisWorkbook.Worksheets(1).Cells(27, 2).Value <> "" And ThisWorkbook.Worksheets(1).Cells(28, 2).Value <> "" Then
OutputSubFolder_name = "\" & ThisWorkbook.Worksheets(1).Cells(24, 2).Value & ExtractString(inputBook_name, ThisWorkbook.Worksheets(1).Cells(27, 2).Value, ThisWorkbook.Worksheets(1).Cells(28, 2).Value) & ThisWorkbook.Worksheets(1).Cells(26, 2).Value &"\"
Else
OutputSubFolder_name = "\" & ThisWorkbook.Worksheets(1).Cells(24, 2).Value & "\"
End If
'ファイル名のブックを開く
Workbooks.Open myPath & inputBook_name
Workbooks.Open templateBook_Path & templateBook_name
'読み込み用のファイルの最終行を取得する
If ThisWorkbook.Worksheets(1).Cells(13, 2).Value <> "" Then
first_row = ThisWorkbook.Worksheets(1).Cells(13, 2).Value
Else
first_row = 2
End If
If ThisWorkbook.Worksheets(1).Cells(14, 2).Value <> "" Then
first_column = ThisWorkbook.Worksheets(1).Cells(14, 2).Value
Else
first_column = 1
End If
If ThisWorkbook.Worksheets(1).Cells(15, 2).Value <> "" Then
last_row = ThisWorkbook.Worksheets(1).Cells(15, 2).Value
Else
'最終行を取得(とりあえず1列目から30列目までを検索)
last_row = 0
For column_number = 1 TO 30
If last_row < Workbooks(inputBook_name).Worksheets(1).Cells(Rows.Count,column_number).End(xlup).Row Then
last_row = Workbooks(inputBook_name).Worksheets(1).Cells(Rows.Count,column_number).End(xlup).Row
End If
Next column_number
End If
If ThisWorkbook.Worksheets(1).Cells(16, 2).Value <> "" Then
last_column =ThisWorkbook.Worksheets(1).Cells(16, 2).Value
Else
last_column = 0
'最終列を取得(とりあえず1行目から30行目までを検索)
For row_number = 1 TO 30
If last_column < Workbooks(inputBook_name).Worksheets(1).Cells(row_number,Columns.Count).End(xlToLeft).Column Then
last_column = Workbooks(inputBook_name).Worksheets(1).Cells(row_number,Columns.Count).End(xlToLeft).Column
End If
Next row_number
End If
'ひな形に元データをコピーして書き込む
For row_number = first_row To last_row
For column_number = first_column To last_column
Workbooks(templateBook_name).Worksheets(templateSheet_name).Cells(row_number + row_hosei, column_number + column_hosei).Value = Workbooks(inputBook_name).Worksheets(1).Cells(row_number, column_number).Value
Next column_number
Next row_number
'-------------------------------------以下、転記先に追加で実践したい処理を記入する------------------------------------------
'----------------------------------------------------------------------------------------------------------------------------
'アラート表示OFF
Application.DisplayAlerts = False
'ファイル名を変更したうえで保存する
Workbooks(templateBook_name).SaveAs myPath & outputBook_name, xlOpenXMLWorkbook
'ブックを閉じる
Workbooks(outputBook_name).Close SaveChanges:=True
Workbooks(inputBook_name).Close SaveChanges:=False
'読み込み用のファイルを、サブフォルダに移動する(重複読み込み防止のため)
Name myPath & inputBook_name As myPath & InputSubFolder_name & inputBook_name
Name myPath & outputBook_name As myPath & OutputSubFolder_name & outputBook_name
inputBook_name = Dir()
Loop
End Sub
Function ExtractString(mystr As String, mykey1 As String, mykey2 As String) As String
Dim mystr2 As String
mystr2 = Mid(mystr, InStr(mystr, mykey1) + 1)
ExtractString = Left(mystr2, InStr(mystr2, mykey2) - 1)
End Function