こんにちは。ichi3270です。
Excelでデータをまとめた表を元にして、送り先ごとに内容が異なる帳票を作ることがあると思います。このような場合、Wordの「差し込み印刷」を使用すると思います。
”印刷して、送ったらおしまい”であれば、それで十分ですね。
でも、送った後に、送り先の人にデータを入力してもらって、返却してもらいたいことってありませんか？
差し込み印刷だと、基本的には紙に印刷になると思うので、記入して返却してもらっても、再利用がしにくいです。
紙じゃなくてExcelデータで帰ってこれば便利なのに・・・
・・・ということで、Excelでまとめた一覧データを元にして、送り先ごとのExcel提出フォーマットを一括出力するツールを作ってみました。
ツールの概要
このツールできることを紹介します。
差し込む先のひな型シート（上記画像の例では、成績報告シートと時間割希望シート）を作成し、mainシートに、出力するファイル名、使用するひな型、差し込むデータを入力します。
準備ができたらファイル出力を押すと・・・
「出力ファイル名」に指定したファイル（例では A先生、Ｂ先生、Ｃ先生）が一気に作成され、中身もそれぞれのファイルに応じた値が差し込まれます。
ダウンロード
＊当ツールの利用によって、ご利用者様、または第三者に損害・トラブル等が発生した場合でも、製作者は一切の責任を負いません。自己責任の上でのご利用をお願いいたします。
使用方法
差し込み先のシートを作成する
まずは、差し込み先のシートを作成してください。
普段Excelで帳票等を作る際と同じように作って頂いてＯＫです。
このツール独自のルール等もありませんので、好きなように作ってください。
先述の例のように、複数の差し込み先シートを作成してもよいですし、１つだけでも問題ありません。
mainシートにデータを入力する
まずは、差込開始行数を設定します。
この例のように 4 を設定した場合、差込先シートの4行目からデータを差込します。
行・列幅自動調整は、４つの選択肢から選択してください。
「しない」以外を選択した場合は、データを差し込んだ後に、行幅や列幅を自動で調整します。
次に、メインのデータを入力します。
出力ファイル名が同じデータは、同じExcelファイルに出力されます。
今回の例では、Ａ先生.xlsx、Ｂ先生.xlsx、Ｃ先生.xlsxという３つのファイルが作成されることになります。
※「出力ファイル名」に「.xlsx」を付ける必要はありません。
差込先シート名は、前の工程で作成したシートの名前を入力してください。
それ以外のシート名は入力しないでください。
Ｃ列から右は、差し込むデータを入力してください。
＊空白のセルは差し込みを行わず無視されます。
なお、６行目（ヘッダ部分）には、差込先の列名を半角大文字のアルファベットで入力してください。
ファイル出力ボタンを押す
準備ができたら、ファイル出力を押してください。
このツールと同じ場所に、files_yyyymmddhhmmssという名前のフォルダが作成され、その中にExcelファイルが出力されます。
＊yyyymmddhhmmssには、年４桁、月２桁、日２桁、時２桁、分２桁、秒２桁の時刻が入ります。
なお、出力されるファイルと同じ名前のファイルを開いている状態で、出力ボタンを押すとエラーになる場合がありますので注意してください。
参考：ソースコード
参考までに、いつもながら拙いですが・・・ソースコードです。
改善点のアドバイス等ございましたら、是非コメント欄などでお知らせください。
Option Explicit
'*** 変数宣言
Private wbThis As Workbook 'このブック
Private wsMain As Worksheet 'mainシート
Private wsWork As Worksheet '作業用シート
Private outDir As String '出力フォルダ名
Private wbOut As Workbook '出力ブック
Private wsOut As Worksheet '出力シート
Private outFileName As String '出力ファイル名
Private outSheetName As String '差込先シート名
Private startRow As Long '差込開始行
Private adjust As String '行列幅調整選択
Private wsCnt As Long 'ワークシートカウンタ
Private rowCnt As Long '行数カウンタ
Sub ファイル差込出力処理()
On Error GoTo Err
MsgBox "ファイル差し込み出力処理を開始します。"
'*** 初期処理
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'*** 初期値設定
Set wbThis = ThisWorkbook
Set wsMain = wbThis.Worksheets("main")
outFileName = ""
outSheetName = ""
startRow = wsMain.Range("B3").Value
adjust = wsMain.Range("B4").Value
'*** 作業用シートを作成
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wsWork = ActiveSheet
'*** 出力先フォルダを作成
outDir = wbThis.Path & "\files_" & Format(Now, "yyyymmddhhmmss")
If Dir(outDir, vbDirectory) = "" Then
MkDir outDir
End If
'*** mainシートのデータを作業用シートにペースト
wsMain.Range("A6").CurrentRegion.Copy wsWork.Range("A1")
'*** 差込先シートの並び順を決定する
wsWork.Columns("B").Insert
'*** 作業用シートの最終行まで、B列に差込先シートのインデックス番号を出力
For rowCnt = 2 To wsWork.Range("A1").CurrentRegion.Rows.Count
For wsCnt = 1 To wbThis.Worksheets.Count - 1
If wsWork.Cells(rowCnt, "C").Value = wbThis.Worksheets(wsCnt).Name Then
wsWork.Cells(rowCnt, "B").Value = wsCnt
End If
Next
Next
'*** 作業用シートをソート
wsWork.Range("A1").CurrentRegion.Sort _
Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, _
Header:=xlYes
'作業列(B列)を削除
wsWork.Columns("B").Delete
'*** データを配列に移し、作業用シートは削除
Dim mainData As Variant
mainData = wsWork.Range("A1").CurrentRegion
wsWork.Delete
'*** メイン処理
Dim i As Long
For i = 2 To UBound(mainData)
outFileName = mainData(i, 1)
outSheetName = mainData(i, 2)
'最初レコードの場合 または 出力ファイルが切り替わった場合、新ブック・シートを作成
If i = 2 Or outFileName <> mainData(i - 1, 1) Then
Workbooks.Add
Set wbOut = ActiveWorkbook
wbOut.Worksheets(1).Name = "DefaultWorkSheet"
Call createNewSheet
wbOut.Worksheets(1).Delete
'新ブックは作成しないが出力シート名が切り替わる場合、新シートを作成
ElseIf outSheetName <> mainData(i - 1, 2) Then
Call finishSheetEdit
Call createNewSheet
End If
'差込
Dim j As Long
For j = 3 To UBound(mainData, 2)
If mainData(i, j) <> "" Then
wsOut.Cells(rowCnt, mainData(1, j)).Value = mainData(i, j)
End If
Next
rowCnt = rowCnt + 1
'最終データ または 次レコードで出力ファイルが切り替わる場合、ファイルを保存して閉じる
If i = UBound(mainData) Then
Call finishBookEdit
ElseIf outFileName <> mainData(i + 1, 1) Then
Call finishBookEdit
End If
Next
'*** 終了処理
wsMain.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox outDir & "にファイルを出力しました。"
Exit Sub
'*** エラー処理
Err:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "エラーが発生したため処理を終了します。利用方法を確認し、データを修正してください。" & vbCrLf & _
"（出力予定のファイルと同名のExcelファイルを開いていないかも確認してください。）"
End Sub
'*** 新たなシートを作成する処理
Function createNewSheet()
wbThis.Worksheets(outSheetName).Copy after:=wbOut.Sheets(wbOut.Sheets.Count)
Set wsOut = wbOut.Worksheets(outSheetName)
rowCnt = startRow
End Function
'*** シートの編集を終了する際の処理
Function finishSheetEdit()
If adjust = "行幅・列幅を調整する" Or adjust = "列幅のみ調整する" Then
wsOut.Range("A" & startRow).CurrentRegion.Columns.AutoFit
End If
If adjust = "行幅・列幅を調整する" Or adjust = "行幅のみ調整する" Then
wsOut.Range("A" & startRow).CurrentRegion.Rows.AutoFit
End If
wsOut.Range("A1").Select
End Function
'*** ブックの編集を終了する際の処理
Function finishBookEdit()
Call finishSheetEdit
wbOut.Worksheets(1).Activate
wbOut.Worksheets(1).Range("A1").Select
wbOut.SaveAs Filename:=outDir & "\" & outFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbOut.Close
End Function
コメント