2024/08/04

Excel VBA セルに入力された日付を取得し自動でシートとファイルを作る方法

仕事でVBAを使うことがあり、やりたいことはネットで調べていますが、VBA初心者の私が分かりづらかったものを、初心者でも分かるように説明したいと思います。

効率的なコードが書けていない可能性もありますので、予めご了承ください。

今回はシートに入力された日付を取得し、その日付から自動でシートとファイルを作成する方法を紹介します。

使用ケース
完成イメージ
下準備
サンプルコード
コード解説

使用ケース

以下のような納品書作成を例にして解説していきます。

仕様の概要としては、

テンプレートに各情報を入力しマクロ実行すると、入力された日付を取得（画像では作成日の2024/7/20）し、取得した日付から何月か判断。
入力された項目を、作成月のサマリシートへ転記。作成月のサマリシートがなければ自動で作成し転記。
テンプレートシートをコピーし、ファイル名を「作成日+NO+取引先名」として、直下に作成された格納フォルダの作成月フォルダへ保存。作成月のフォルダがなければ自動作成。

完成イメージ

①テンプレートの各項目を入力し、マクロ実行。

②作成月（yyyymm）のサマリシートを作成し、各項目を転記。サマリシートが既に存在する場合は転記のみ実行。転記した時点でステータスは「出力済」を選択する。

既にサマリシートが存在し、同じ名前が存在する場合、処理を継続するか確認を行います（重複チェック）。継続しない場合は、処理を終了します。

③テンプレートシートを新規ブックにコピーし、ファイル名「作成日+NO+取引先名」として、直下の納品書格納フォルダに保存します。

納品書格納フォルダは作成月でフォルダを作成、既に存在する場合は保存のみ実行。

下準備

マクロの前に、下準備としてサマリシートの原本を作成しておきます。

シート名は「サマリ原本」とする。
項目はテンプレートの各項目を列挙。
管理用としてステータス行を追加。ステータスの内容は入力規則で設定しておく。
シートは作成後、非表示としておく。

サンプルコード

まずはコード全文です。セクションごとの解説は後述します。


Sub 作成()

buf = Range("G3").Value
buf2 = Replace(buf, "/", "")
buf3 = Left(buf2, 6)
buf4 = Range("A2").Value

'重複チェック
Dim myRange As Range
Dim myObj As Range

For i = 2 To Worksheets.Count
	Sheets(i).Activate
	Columns("B").Select
	Set myObj = Cells.find(What:=buf4, LookAt:=xlWhole)
Next

If myObj Is Nothing Then

Else
	If MsgBox("同じ取引先名が存在しています。処理を継続しますか？", vbYesNo) = vbNo Then
		Sheets("テンプレート").Activate
		Exit Sub
	End If
End If

'シート作成
Dim flag As Boolean
For Each ws In Worksheets
	If ws.Name = buf3 Then flag = True
Next ws

If flag = True Then

Else
	Worksheets("サマリ原本").Visible = True
	Worksheets("サマリ原本").Copy After:=Worksheets(Worksheets.Count)
	ActiveSheet.Name = Format(buf3)
	Worksheets("サマリ原本").Visible = False
End If

Sheets("テンプレート").Select

'サマリシートへ転記
Dim tgt1, tgt2, tgt3, tgt4, tgt5, tgt6, tgt7, tgt8

tgt1 = Range("A2").Value
tgt2 = Range("G2").Value
tgt3 = Range("G3").Value
tgt4 = Range("B6").Value
tgt5 = Range("B7").Value
tgt6 = Range("B8").Value
tgt7 = Range("B9").Value
tgt8 = Range("B11").Value

Sheets(buf3).Select
lastrow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(2, lastrow).Select

Cells(lastrow, 2).Value = tgt1
Cells(lastrow, 3).Value = tgt2
Cells(lastrow, 4).Value = tgt3
Cells(lastrow, 5).Value = tgt4
Cells(lastrow, 6).Value = tgt5
Cells(lastrow, 7).Value = tgt5
Cells(lastrow, 8).Value = tgt7
Cells(lastrow, 9).Value = tgt8
Cells(lastrow, 1).Value = "出力済"

'フォルダ作成
Dim SaveDir As String
SaveDir = "C:\Users\Owner\Desktop\納品書作成ツール\納品書格納\" & buf3

If Dir(SaveDir, vbDirectory) = "" Then
	MkDir SaveDir
End If

'ファイル作成
Dim wb As Workbook
Dim sht As Worksheet

Set wb = Workbooks.Add
Call ThisWorkbook.Worksheets("テンプレート").Copy(before:=wb.Worksheets(wb.Worksheets.Count))
ActiveSheet.Name = "納品書"
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Delete


wb.SaveAs Filename:="C:\Users\Owner\Desktop\納品書作成ツール\納品書格納\" & buf3 & "\" & buf2 & tgt2 & tgt1 & ".xlsx"
wb.Close

Sheets("テンプレート").Activate

End Sub

コード解説

コードが長くなってしまったため、基本的にコメントで解説していきます。

値取得し変数格納


buf = Range("G3").Value	'作成日取得
buf2 = Replace(buf, "/", "")	'bufからスラッシュ削除
buf3 = Left(buf2, 6)	'buf2からyyyymm取得
buf4 = Range("A2").Value	'取引先名取得

重複チェック


Dim myRange As Range
Dim myObj As Range

For i = 2 To Worksheets.Count	'シート2枚目以降から最後のシートまで繰り返し
	Sheets(i).Activate	'シートをアクティブに
	Columns("B").Select	'B列を選択
	Set myObj = Cells.find(What:=buf4, LookAt:=xlWhole)	'取得した取引先名をfindで検索し、該当があれば変数myObjに格納
Next

If myObj Is Nothing Then
	'同じ取引先名が存在しなかった場合、なにもしない

Else
	'同じ取引先名が存在する場合、処理継続の選択。継続しない場合マクロを終了
	If MsgBox("同じ取引先名が存在しています。処理を継続しますか？", vbYesNo) = vbNo Then
		Sheets("テンプレート").Activate	'"テンプレート"シートをアクティブに
		Exit Sub	'マクロを終了
	End If
End If

シート作成


Dim flag As Boolean
For Each ws In Worksheets	'ブック内のすべてのワークシートで同じ処理を行う 
 If ws.Name = buf3 Then flag = True	'作成月（yyyymm）と同じシート名があればフラグをTrueとする
Next ws

If flag = True Then
	'すでにシートがある場合なにもしない

Else
	'シートがない場合
	Worksheets("サマリ原本").Visible = True '"サマリ原本"シートが非表示の場合表示する
	Worksheets("サマリ原本").Copy After:=Worksheets(Worksheets.Count) '"サマリ原本"をコピーして最後尾へ追加
	ActiveSheet.Name = Format(buf3)  ' シート名を作成月（yyyymm）へ変更
	Worksheets("サマリ原本").Visible = False '"サマリ原本"シートが表示の場合非表示にする
End If

サマリシートへ転記


'転記項目を変数に格納
Dim tgt1, tgt2, tgt3, tgt4, tgt5, tgt6, tgt7, tgt8

tgt1 = Range("A2").Value	'取引先名
tgt2 = Range("G2").Value	'NO
tgt3 = Range("G3").Value	'納品日
tgt4 = Range("B6").Value	'件名
tgt5 = Range("B7").Value	'納期
tgt6 = Range("B8").Value	'納品場所
tgt7 = Range("B9").Value	'支払条件
tgt8 = Range("B11").Value	'合計

Sheets(buf3).Select	'作成月（yyyymm）シートを選択
lastrow = Cells(Rows.Count, 2).End(xlUp).Row + 1		'最終行＋1の行数取得
Cells(2, lastrow).Select		'B列の最終行＋1列を選択

'各項目の転記を実施
Cells(lastrow, 2).Value = tgt1
Cells(lastrow, 3).Value = tgt2
Cells(lastrow, 4).Value = tgt3
Cells(lastrow, 5).Value = tgt4
Cells(lastrow, 6).Value = tgt5
Cells(lastrow, 7).Value = tgt5
Cells(lastrow, 8).Value = tgt7
Cells(lastrow, 9).Value = tgt8
Cells(lastrow, 1).Value = "出力済"	'ステータスを"出力済"にする

フォルダ作成

フォルダのパスはお好きな場所に変更してください。


Dim SaveDir As String
SaveDir = "C:\Users\Owner\Desktop\納品書作成ツール\納品書格納\" & buf3	'直下の納品書格納フォルダに作成月（yyyymm）フォルダが存在するかチェック

If Dir(SaveDir, vbDirectory) = "" Then	'フォルダがなければ
	MkDir SaveDir	'納品書格納フォルダにyyyymmフォルダを作成
End If

ファイル作成


Dim wb As Workbook
Dim sht As Worksheet

Set wb = Workbooks.Add	'新規ブックを変数に格納
Call ThisWorkbook.Worksheets("テンプレート").Copy(before:=wb.Worksheets(wb.Worksheets.Count))	'テンプレートシートをコピーして、新規ブックにコピー
ActiveSheet.Name = "納品書"	'シート名を"納品書"へ
ActiveSheet.Shapes.SelectAll	'シート内の図形を全選択（作成開始ボタンを削除するため選択）
Selection.ShapeRange.Delete	'図形を削除（作成開始ボタンを削除）

wb.SaveAs Filename:="C:\Users\Owner\Desktop\納品書作成ツール\納品書格納\" & buf3 & "\" & buf2 & tgt2 & tgt1 & ".xlsx"	'ファイル名「作成日+NO+取引先名」として名前を付けて保存
wb.Close

Sheets("テンプレート").Activate

補足

今回は実装しませんでしたが、最後に"テンプレート"シートの入力項目をリセットしてもいいかもしれませんね。その場合、以下を追加すればOKです。


Range("A2").Value = ""	'取引先名
Range("G2").Value = ""	'NO
Range("G3").Value = ""	'納品日
Range("B6").Value = ""	'件名
Range("B7").Value = ""	'納期
Range("B8").Value = ""	'納品場所
Range("B9").Value = ""	'支払条件

以上、セルに入力された日付を取得し、自動でシートとファイルを作る方法でした。

何らかの情報を元にファイルを作成する仕組みは、マクロを実行した時に自動でバックアップファイルを作成するなど、実務上でも大変役に立つ技術だと思いますので、ぜひマスターしておきたいですね。