こんにちは！ 健史(たけふみ)です。
この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。
最初は、真似ることです。
少しづつ何回も Excel-VBAの起動、実行に慣れて、プログラムにも目を通して理解を深め、自然に手が動くようになるまで頭の回路に焼き付けて頂ければと思います。
そして、活用できるレベルにいって頂ければと嬉しく思います。
Excel-VBAの構造、起動方法、実行方法などを理解されていない方は、以下の記事を参照しながら一度やってみてから対応されることをお勧めします。
実行中に発生したエラーの対処法は、上記記事の2.エラーが発生したときの対処法に記載しています。(この段落のリンクから直接遷移します)
プログラムの作成と実行
今回のサンプルプログラムは
です。
今回のサンプルは、顧客アンケートシートがExcel形式で一人ひとり分あり、そこから一人ひとり分の返信シートを作成するプログラムです。
実際には顧客アンケートシートから返信シートを作成するといったことはないかもしれませんが、要は何十件、何百件とあるExcelファイル１つに対して１つずつ別ファイルを作成する場合です。
顧客アンケートは
[顧客アンケート_名前_日付.xls]で、例えば[顧客アンケート_青森太郎_20190501.xls]
です。
それを[ご返信_青森太郎様.xls]といったファイル名で、しかも、そのフォーマットが決まっている例です。
仕様概要は、以下の通りです。
・所定のフォルダに格納されている顧客アンケートのExcelファイルを順次読み込む
・読み込んだファイル名をプログラム内に格納する
・ひな形の返信Excelファイルを読み込む
・ファイル名をプログラム内に格納したデータなどから編集して返信ファイルとして書き込む
顧客アンケートシートが数百件、数千件ある場合には、そのファイルを作るだけでも大変ですし、ファイル名を間違えたりしてしまうこともあります。
そんなとき、顧客アンケートシートから名前だけでも持ってきて、フォーマットを読み込み、ファイル名や内容に変更して自動設定してご返信シートを一気に作成してしまう処理です。
ファイル作成を自動で行ってくれれば、ご返信シートの記入に注力できます。
そんな時に対応するプログラムです。
実行までの手順
1.データ準備
予めアンケートシート、ひな形シートを作成しておきます。
1).アンケートシート
アンケートシートを格納するフォルダ内にExcelファイルを作成します。
この例では、データは何も入力していません。
2).返信用のひな形シート
ひな形シートを格納するフォルダ内にExcelファイルを作成します。
この例では、データは何も入力していません。
2.Excelを起動
1).シート１に以下のデータを貼り付ける
ドラッグ＆コピー後にExcelに貼り付けるとき、[形式を選択して貼り付ける]-[テキスト]で貼り付けます。(セル[A1]で[右クリック]、[形式を選択して貼り付ける]-[テキスト])
参照フォルダ 参照ファイル アンケートシート F:\70.EXCEL-VBA\01.In － ひな形シート F:\70.EXCEL-VBA\02.HINAGATA 返信.xls 返信シート F:\70.EXCEL-VBA\03.OUT －
プログラムを実行する場合のフォルダ名やファイル名は、実際の環境に合わせて修正します。
3.Excel-VBAを起動
Altを押した状態でF8キーを押します。
4.[マクロ名(M):]に'test'と入力(''は不要、''内のtestを入力)
5.[作成(C)]をクリック
私はマクロ名を入力したら、そのままEnterを押します。
6.以下のプログラムをドラッグ＆コピー
'アンケートフォルダ内を読み込むときの対象を定義、*は全てを意味する
Const cnsDIR = "\*.*"
'フォルダやファイルの場所用の変数を定義
Dim strPath1 As String
Dim strPath2 As String
Dim strFile2 As String
Dim strPath3 As String
'ファイル名を格納するテーブルを定義
Dim tblFilename1(500) As String
Dim i, last_i As Long
'アンケートフォルダから取得するファイル名用の変数を定義
Dim strFilename As String
'ファイル名から名前を抽出するために使う変数を定義
Dim pos_st, pos_end, pos_len As Long
Dim strName As String
'返信フォルダに出力するために使う変数を定義
Dim book1 As Workbook
Dim savFilename As String
'フォルダやファイルの場所をワークに取り込む
strPath1 = Worksheets(1).Cells(2, 2)
strPath2 = Worksheets(1).Cells(4, 2)
strFile2 = Worksheets(1).Cells(4, 3)
strPath3 = Worksheets(1).Cells(6, 2)
'フォルダの存在確認 --- 必要な場合のみ記述 ---
If Dir(strPath1, vbDirectory) = "" Then
MsgBox "アンケートフォルダがない", vbExclamation
Exit Sub
End If
If Dir(strPath2, vbDirectory) = "" Then
MsgBox "ひな形フォルダがない", vbExclamation
Exit Sub
End If
If Dir(strPath2 & "\" & strFile2, vbDirectory) = "" Then
MsgBox "ひな形ファイルがない", vbExclamation
Exit Sub
End If
If Dir(strPath3, vbDirectory) = "" Then
MsgBox "返信フォルダがない", vbExclamation
Exit Sub
End If
'アンケートフォルダ内の最初のファイルを取得
strFilename = Dir(strPath1 & cnsDIR, vbNormal)
i = 0
Do While strFilename <> ""
' 行を加算
i = i + 1
tblFilename1(i) = strFilename
'次のファイル名を取得
strFilename = Dir()
Loop
'アンケートシートの件数を退避
last_i = i
'ひな形ファイルを読み込み、返信ファイルを編集して出力
For i = 1 To last_i
'ひな型ファイルをオープン
Workbooks.Open strPath2 & "\" & strFile2
'ひな形ファイルにファイル名を編集
Worksheets(1).Cells(2, 3).Value = tblFilename1(i)
'ファイル名から名前だけを抽出
pos_st = InStr(1, tblFilename1(i), "_")
pos_st = pos_st + 1
pos_end = InStr(pos_st, tblFilename1(i), "_")
pos_len = pos_end - pos_st
strName = Mid(tblFilename1(i), pos_st, pos_len)
'返信ファイル名を生成
savFilename = strPath3 & "\" & "ご返信_" & strName & "様.xls"
'返信ファイルが存在しない場合のみ書く
Set book1 = ActiveWorkbook
If Dir(savFilename, vbDirectory) = "" Then
book1.SaveAs savFilename
End If
'上書きしないで閉じる
Call book1.Close(False)
Next
'起動しているExcelを終了する
Application.Quit
6.以下に貼り付け(ペースト)
Sub test()
ここに貼り付ける
End Sub
7.F5キーで実行
8.実行結果の確認
返信フォルダには、アンケートフォルダ内のファイル名とひな形ファイルから作成された返信ファイルが作成されています。
プログラムの詳細説明
アンケートフォルダ内のExcelファイルを読み込む処理は、以下の記事を参照下さい。
For文については、以下の記事を参照下さい。
上記記事にない部分を追記します。
・フォルダやファイルの場所用の変数を定義
Dim strPath1 As String
Dim strPath2 As String
Dim strFile2 As String
Dim strPath3 As String
上記[2-1)]で指定したアンケートシートフォルダ、ひな形フォルダ、ひな形ファイル、返信シートフォルダをプログラム内で使いやすくするために、変数として定義し以後の処理「フォルダやファイルの場所をワークに取り込む」で取り込みます。
"使いやすく"というのは、アンケートシートフォルダの場合[Worksheets(1).Cells(2, 2)]では長いですし、何なのか分かりずらいです。
ですから、わかりやすい変数として定義し値を取り込みます。
・ファイル名を格納するテーブルを定義
Dim tblFilename1(500) As String
変数:tblFilename1を500個定義します。
Worksheets(2)に取り込んで参照しても良いのですが、返信ファイルを書き出すときにひな形ファイルを読み込むので「あっちのファイルを見たり、こっちのファイルを見たり」ということをしたくないので、プログラム内に定義した変数を使いました。
参照する場合には、tblFilename1(1)やtblFilename1(i)というように後ろに'()'をつけて、何番目かを指定します。
・ファイル名から名前を抽出するために使う変数を定義
Dim pos_st, pos_end, pos_len As Long
文字通り以後の処理「ファイル名から名前だけを抽出」で使う変数です。後述の説明を参照下さい。
・返信フォルダに出力するために使う変数を定義
Dim book1 As Workbook]
「返信ファイルが存在しない場合のみ書く」で使う変数で、"このように定義しておくことが必要"とご理解下さい。
・フォルダやファイルの場所をワークに取り込む
strPath1 = Worksheets(1).Cells(2, 2)
strPath2 = Worksheets(1).Cells(4, 2)
strFile2 = Worksheets(1).Cells(4, 3)
strPath3 = Worksheets(1).Cells(6, 2)
上記で定義した変数にアンケートシートフォルダ、ひな形フォルダ、ひな形ファイル、返信シートフォルダに取り込みます。
・ひな型ファイルをオープン
Workbooks.Open strPath2 & "\" & strFile2
\70.EXCEL-VBA\02.HINAGATA\返信.xlsをオープンします。
・ファイル名から名前だけを抽出
① pos_st = InStr(1, tblFilename1(i), "_")
② pos_st = pos_st + 1
③ pos_end = InStr(pos_st, tblFilename1(i), "_")
④ pos_len = pos_end - pos_st
⑤ strName = Mid(tblFilename1(i), pos_st, pos_len)
①.[顧客アンケート_岩手一太郎_20190501.xls]の1文字目から"_"の文字位置を求めます。
pos_stには[8]が入ります。
②.[岩手一太郎]の"岩"の位置を求めます。
pos_stは[9]になります。
③.9文字目から次の"_"の文字位置を求めます。
pos_endは[14]が入ります。
④.名前[岩手一太郎]の文字数を求めます。
pos_lenは14-9＝[5]になります。
⑤.9文字目から5文字を抽出します。
変数:strNameには[岩手一太郎]が入ります。
追加で補足します。
まず、①、③で検索する文字が無かった場合には、pos_st,pos_endには0(ゼロ)が返ってきます。
ですから、文字列が無い場合の対応として「If pos_st = 0 Then Exit Sub End If」としても良いでしょう。
ただし、Exit Subの前にMsgbox文などでエラーの情報を表示する処理が必要です。でないと何で終わったか分かりませんので。
次に複数文字を検索する場合、例えば③で"_2019"を検索すると、あくまで文字列の開始位置であって、上記では14が返ってきます。
・返信ファイル名を生成
savFilename = strPath3 & "\" & "ご返信_" & strName & "様.xls"
F:\70.EXCEL-VBA\03.OUT\ご返信_岩手一太郎様.xlsが生成されます。
・返信ファイルが存在しない場合のみ書く
Set book1 = ActiveWorkbook
If Dir(savFilename, vbDirectory) = "" Then
book1.SaveAs savFilename
End If
文字通り、F:\70.EXCEL-VBA\03.OUT\ご返信_岩手一太郎様.xlsが存在しない場合に出力します。
・上書きしないで閉じる
Call book1.Close(False)
開いているExcelファイルを閉じます。
最後に
ひな形ファイルを使って作成するファイルが少なければ必要ありませんが、大量な場合には便利です。
今回、編集処理は１項目だけでしたが、例えば今日の日付編集したり、編集する項目が複数あると漏れたり間違えたりします。
プログラムで処理すれば間違えることなく処理します。
出力ファイルにつける名前は実際にはアンケートシートに入っていると思いますが、今回敢えてファイル名から名前を抽出する処理も入れてみました。
文字列にルールがある場合には使えます。
使うシーンに応じて対応して頂ければと思います。
コメント