１つのテンプレートファイルから、違うファイル名で沢山ファイルを作りたい時ってありません？
例えば、
・スタッフの数だけ同じファイルを作りたい
・支店や部署の数だけ同じファイルを作りたい
・１月から１２月まで同じファイルを作りたい
・１０年分同じファイルを作りたい
とか。
私はこういう場面、よくあるんです。
なので、
１．１つのテンプレートファイルから別名で複数のファイルを自動で作成する
２．複数のテンプレートファイルから別名で複数のファイルを自動で作成する
２つの方法をVBAで、「FileCopy」ステートメントでマクロを作っています。
結構、便利なので参考にしてください。
投稿者「みか」自己紹介
- パソコンとデータベースが大好き
- 自社でネットワーク・システム・機器管理、Webサイト構築
- 自社向けのシステムをMicrosoft AccessやPHPで多数構築
- Excelでの作業はVBAを使って効率化
- ロックバンド「VARS」でベース担当
- 「VARS」のWebサイト、ブログも構築
- 「VARS」のライブを観に来てね！https://vasofatum.jp/live/
１つのテンプレートファイルから別名で複数のファイルを自動で作成する
１つのテンプレートファイルから別名で複数のファイルを自動で作成する方法です。
マクロは「ファイルコピー用.xlsm」というブックに書き込んでいます。
「テンプレート.xlsx」というファイルから複数のファイルを同フォルダ内の「コピー先」というフォルダに作っていきます。
Ｂ１セルにテンプレートのファイル名を拡張子付きで入力します。
４行目から作成したいファイル名を入力します。拡張子は、テンプレートファイルから取得するので入力しません。
※Ａ列は、ファイル名に番号を入れたかったので、番号を入力しています。ファイル名に変換するときは「1」→「001」「2」→「002」となるように変換しています。
↓コードはこちら。
Sub goFileCopy1()
Dim wb As Workbook
Dim ws As Worksheet
Dim wbPath As String
Dim wbCopyPath As String
Dim fExtArr As Variant
Dim fExt As String
Dim fNameBefore As String
Dim fNameAfter As String
Dim LastRow As Long
Dim i As Long
'ブックとシートをset
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
'このブックのパス
wbPath = wb.Path & "\"
'コピー先フォルダパス
wbCopyPath = wbPath & "コピー先\"
'コピー先フォルダがあるかどうか
If Dir(wbCopyPath, vbDirectory) = "" Then
MkDir wbCopyPath
End If
'A3から下に向かって最終行を取得
LastRow = ws.Range("A3").End(xlDown).Row
'テンプレートファイルを指定
fNameBefore = wbPath & ws.Range("B1").Value
'テンプレートファイルから拡張子を取得
fExtArr = Split(ws.Range("B1").Value, ".")
fExt = "." & fExtArr(UBound(fExtArr))
'最終行まで新ファイル名を生成し、ファイルをコピーする
For i = 4 To LastRow
fNameAfter = wbCopyPath & Format(ws.Cells(i, 1).Value, "000")
fNameAfter = fNameAfter & ws.Cells(i, 2).Value & fExt
FileCopy fNameBefore, fNameAfter
Next i
MsgBox "終了"
End Subマクロを実行すると、「コピー先」フォルダに新しいファイルが出来ました！
※マクロ実行時は、テンプレートファイルは閉じておきます。
複数のテンプレートファイルから別名で複数のファイルを自動で作成する
次は、複数のテンプレートファイルから別名で複数ファイルを自動で作成する方法です。
マクロは「ファイルコピー用.xlsm」というブックに書き込んでいて、同フォルダ内の「コピー先」というフォルダに新しいファイルを作っていきます。
Ａ列にテンプレートのファイル名を拡張子付きで入力します。
Ｂ，Ｃ列に作成したいファイル名を入力します。拡張子は、テンプレートファイルから取得するので入力しません。
今回は、Wordファイルも入れてみました。
※Ｂ列は、ファイル名に番号を入れたかったので、番号を入力しています。ファイル名に変換するときは「1」→「001」「2」→「002」となるように変換しています。
↓コードはこちら。
Sub goFileCopy2()
Dim wb As Workbook
Dim ws As Worksheet
Dim wbPath As String
Dim wbCopyPath As String
Dim fExtArr As Variant
Dim fExt As String
Dim fNameBefore As String
Dim fNameAfter As String
Dim LastRow As Long
Dim i As Long
'ブックとシートをset
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet2")
'このブックのパス
wbPath = wb.Path & "\"
'コピー先フォルダパス
wbCopyPath = wbPath & "コピー先\"
'コピー先フォルダがあるかどうか
If Dir(wbCopyPath, vbDirectory) = "" Then
MkDir wbCopyPath
End If
'A1から下に向かって最終行を取得
LastRow = ws.Range("A1").End(xlDown).Row
'最終行までテンプレートファイル名を取得し、新ファイル名を生成し、ファイルをコピーする
For i = 2 To LastRow
'テンプレートファイルを指定
fNameBefore = wbPath & ws.Cells(i, 1).Value
'テンプレートファイルから拡張子を取得
fExtArr = Split(fNameBefore, ".")
fExt = "." & fExtArr(UBound(fExtArr))
'新ファイル名を生成し、ファイルをコピーす'
fNameAfter = wbCopyPath & Format(ws.Cells(i, 2).Value, "000")
fNameAfter = fNameAfter & ws.Cells(i, 3).Value & fExt
FileCopy fNameBefore, fNameAfter
Next i
MsgBox "終了"
End Subマクロを実行すると、「コピー先」フォルダに新しいファイルが出来ました！
※マクロ実行時は、テンプレートファイルは閉じておきます。
「FileCopy」ステートメント構文
「FileCopy」ステートメントは、ファイルをコピーします。
FileCopy source, destination
source：必須。コピー元のファイル名を指定します。ディレクトリ、フォルダーおよびドライブを含めることができます。
destination：必須。コピー先のファイル名を指定します。ディレクトリ、フォルダーおよびドライブを含めることができます。
開いているファイルで「FileCopy」ステートメントを使用しようとすると、エラーが発生します。
サンプル
Publicドキュメントフォルダの「aaa.docx」のファイルを、Publicピクチャフォルダに「bbb.docx」にコピーするサンプルです。
Sub test()
FileCopy "C:\Users\Public\Documents\aaa.docx", "C:\Users\Public\Pictures\bbb.docx"
End Sub