こんにちは！ 健史です。
ということありませんか。
例えば「顧客別のExcelファイルから、返信シートを１人ひとり分作成しなければならない」ということです。
顧客別のファイルでなくても、多くの製品に使われている共通の部品やプログラムの変更から全製品やプログラムの試験や動作確認を行うとき、ひな形からテスト仕様書ファイルを全製品分作成しなければならない場合です。
対象が100も200もあったらファイルを作成するだけでも大変な作業です。
ひな形から作成した内容、顧客名や製品名なども個別に変更する必要もあります。
ただでさえ緻密な製品テストなどに労力を使うのに、単純なファイル作成に使うのは勿体ないです。
プログラムで自動作成する処理を作成してみました。
プログラムの作成と実行
今回のサンプルプログラムは
です。
今回のサンプルは、顧客アンケートシートがExcel形式で一人ひとり分あり、そこから一人ひとり分の返信シートを作成するプログラムです。
実際には顧客アンケートシートから返信シートを作成するといったことはないかもしれませんが、要は何十件、何百件とあるExcelファイル１つに対して１つずつ別ファイルを作成する場合です。
顧客アンケートは
[顧客アンケート_名前_日付.xlsx]で、例えば[顧客アンケート_青森太郎_20190501.xlsx]
です。
それを[ご返信_青森太郎様.xlsx]といったファイル名で、しかも、そのフォーマットが決まっている例です。
仕様概要は、以下の通りです。
・アンケートシートフォルダに格納されているファイル名をシート２に取得する
・ひな形の返信Excelファイルを読み込む
・シート２に格納したファイル名を編集して返信ファイル名として書き込む
顧客アンケートシートが数百件、数千件ある場合には、そのファイルを作るだけでも大変ですし、ファイル名を間違えたりしてしまうこともあります。
そんなとき、顧客アンケートシートから名前だけでも持ってきて、フォーマットを読み込み、ファイル名や内容に変更して自動設定してご返信シートを一気に作成してしまう処理です。
ファイル作成を自動で行ってくれれば、ご返信シートの記入に注力できます。
そんな時に対応するプログラムです。
実行までの手順
1.データ準備
予めアンケートファイル、返信用ひな形ファイルを作成しておきます。
1).アンケートファイル
アンケートシートフォルダ内に格納しておきます。
この例では、データは何も入力していません。
プログラム先頭でファイルの抽出指定を[xls*]としていますから、xls,xlsx,xlsmなどが抽出されます。
例えば拡張子を[xlsx]だけにしたい場合は、ファイルの抽出指定を[xls*]を[xlsx]に変更します。
2).返信用のひな形ファイル
ひな形フォルダ内に格納しておきます。
2.Excelを起動
1).シート１に以下のデータを貼り付ける
ドラッグ＆コピー後にExcelに貼り付けるとき、[形式を選択して貼り付ける]-[テキスト]で貼り付けます。(セル[A1]で[右クリック]、[形式を選択して貼り付ける]-[テキスト])
設定項目 設定内容 アンケートシート C:\TEMP01\01.アンケートシート ひな形フォルダ C:\TEMP01\02.ひな形 ひな形ファイル 返信.xlsx 返信シート C:\TEMP01\03.返信シート
プログラムを実行する場合のフォルダ名やファイル名は、実際の環境に合わせて修正します。
3.Excel-VBAを起動
Altを押した状態でF8キーを押します。
4.[マクロ名(M):]に'test'などと入力(''は不要、''内のtestを入力)
5.[作成(C)]をクリック
私はマクロ名を入力したら、そのままEnterを押します。
6.以下のプログラムをドラッグ＆コピー
'アンケートフォルダ内を読み込むときの対象を定義、*は全てを意味する
Const cnsDIR = "\*.xls*"
'フォルダやファイルの場所用の変数を定義
Dim strPath1 As String
Dim strPath2 As String
Dim strFile2 As String
Dim strPath3 As String
'ファイル名を格納するテーブルを定義
Dim ix1, ix1_max As Long
'アンケートフォルダから取得するファイル名用の変数を定義
Dim strFilename As String
'ファイル名から名前を抽出するために使う変数を定義
Dim pos_st, pos_end, pos_len As Long
Dim strName As String
'返信フォルダに出力するために使う変数を定義
Dim excel0, excel1 As Workbook
Dim savFilename As String
'画面遷移を表示させない設定
Application.ScreenUpdating = False
'変数:excel1に起動した(この)ファイルを設定
Set excel0 = ActiveWorkbook
'フォルダやファイルの場所をワークに取り込む
strPath1 = excel0.Sheets(1).Cells(2, 2)
strPath2 = excel0.Sheets(1).Cells(3, 2)
strFile2 = excel0.Sheets(1).Cells(4, 2)
strPath3 = excel0.Sheets(1).Cells(5, 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
'各シートを初期クリア
Select Case excel0.Sheets.Count 'シート２，シート３を追加し忘れた時の対応
Case 1
excel0.Sheets.Add(After:=excel0.Sheets(excel0.Sheets.Count)).Name = "ワーク"
End Select
excel0.Sheets(2).Cells.Clear
'アンケートフォルダ内の最初のファイルを取得
strFilename = Dir(strPath1 & cnsDIR, vbNormal)
ix1 = 0
Do While strFilename <> ""
ix1 = ix1 + 1
excel0.Sheets(2).Cells(ix1, 1) = strPath1 & "\" & strFilename
excel0.Sheets(2).Cells(ix1, 2) = strPath1
excel0.Sheets(2).Cells(ix1, 3) = strFilename
strFilename = Dir()
Loop
'アンケートシートの件数を退避
ix1_max = ix1
'ひな形ファイルを読み込み、返信ファイルを編集して出力
For ix1 = 1 To ix1_max
'ひな型ファイルをオープン
Set excel1 = Workbooks.Open(strPath2 & "\" & strFile2)
'ひな形ファイルにファイル名を編集
excel1.Sheets(1).Cells(2, 3) = excel0.Sheets(2).Cells(ix1, 3)
'ファイル名から名前だけを抽出
pos_st = InStr(1, excel0.Sheets(2).Cells(ix1, 3), "_")
pos_st = pos_st + 1
pos_end = InStr(pos_st, excel0.Sheets(2).Cells(ix1, 3), "_")
pos_len = pos_end - pos_st
strName = Mid(excel0.Sheets(2).Cells(ix1, 3), pos_st, pos_len)
'返信ファイル名を生成
savFilename = strPath3 & "\" & "ご返信_" & strName & "様.xlsx"
'返信ファイルが存在しない場合のみ書く
If Dir(savFilename, vbDirectory) = "" Then
excel1.SaveAs savFilename
End If
'上書きしないで閉じる
Call excel1.Close(False)
Next
'終了する
excel0.Save
MsgBox "処理終了！"
6.以下に貼り付け(ペースト)
Sub test()
ここに貼り付ける
End Sub
7.F5キーで実行
8.実行結果の確認
返信フォルダには、アンケートフォルダ内のファイル名とひな形ファイルから作成された返信ファイルが作成されます。
プログラムの補足説明
・ファイル名から名前だけを抽出
① 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が返ってきます。
・返信ファイルが存在しない場合のみ書く
If Dir(savFilename, vbDirectory) = "" Then
excel1.SaveAs savFilename
End If
返信フォルダにファイルが存在しない場合に出力します。
ある場合は更新しませんので、更新したい場合は削除してから実行します。
最後に
ひな形ファイルを使って作成するファイルが少なければ必要ありませんが、大量な場合には便利です。
今回、編集処理は１項目だけでしたが、例えば今日の日付を編集したり、編集する項目が複数あると漏れたり間違えたりします。
プログラムで処理すれば間違えることなく処理します。
出力ファイルにつける名前は実際にはアンケートシートに入っていると思いますが、今回敢えてファイル名から名前を抽出する処理も入れてみました。
文字列にルールがある場合には使えます。
また、ワークシートは入力ファルダから抽出した処理対象ファイルの一覧ですから、チェック表としても活用できます。
使うシーンに応じて対応して頂ければと思います。
尚この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。
Excel-VBAの構造、起動方法、実行方法などを理解されていない方は、以下の記事を参照しながら一度やってみてから対応されることをお勧めします。
実行中に発生したエラーの対処法は、上記記事の2.エラーが発生したときの対処法に記載しています。(この段落のリンクから直接遷移します)
コメント