賞状データ作成 - Infomentのブログ～Excel VBA奮闘記～

昨日まで「賞状印刷用データ」に必要な項目を、印刷にふさわしい
形に整えることに挑戦してきた。
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
今日も、昨日の続きから。

おさらいすると、賞状に反映すべき情報は以下の三つ。

部門　例）小学生三年女子　組手の部
順位　例）優勝
名前　例）山田花子

あらかじめフォント名やサイズ、印刷位置などを調整済みのWordファイルが
あって、これに反映したのち印刷したい。

ところでWord文章内の特定の位置に、特定のフォント名、サイズで文字列を
セットするには、どうすればよいのだろう？きっと方法があるのだろうけど、
私はその方法を未だ知らない。

ということで今回は、「既にセットされた文字を置換する」方式とした。
作戦はこうだ。

必要な情報を取得する。
Wordのひな形を起動する。
部門名、順位、選手名をそれぞれ置換する。
置換後のファイルを、内容が解り易いファイル名で保存する。
一位～四位まで、これを繰り返す。

まずひな形ファイルをC\Tempに保存。内容は、先日から少々変更した。

また、関数「生徒の名前」も「選手名」に変更。成人が選手の場合もあるので。

以上を踏まえて作成したのが ↓ こちら。

Sub 賞状作成()
    ' Excelで選んだ人の名前を格納するための配列。
    Dim arr As Variant
        arr = 選手名
        
    Dim SrcArray As Variant
        SrcArray = Array("部門名", "順位", "選手名")
    
    ' Microsoft Word *.* Object Libraryを事前に参照設定のこと。
    ' 「Wordそのもの」を設定。
    Dim objWord As Word.Application
    Set objWord = CreateObject("Word.Application")
        objWord.Visible = True

    ' 置換後の文字列を格納する配列を作成。
    Dim DstArray(0 To 2) As Variant
    ' シート名が学年や男女・形名になっている。
        DstArray(0) = 部門変換(ActiveSheet.Name)
    ' Word内の文字列。
    Dim docDoc As Word.Document
    ' 文字列の置換。
    Dim objFind As Word.Find
    Dim i As Long
    Dim j As Long
        For i = 0 To UBound(arr)
            DstArray(1) = 順位(i)
            DstArray(2) = arr(i)
            
            ' 原紙ファイルを開く。
            Set docDoc = objWord.Documents.Open("C:\Temp\賞状ひな形.docx")
            Set objFind = objWord.Selection.Find
            
            ' 順番に文字列を置換。
            For j = 0 To 2
                objFind.ClearFormatting
                objFind.Text = SrcArray(j)
                objFind.Replacement.ClearFormatting
                objFind.Replacement.Text = DstArray(j)
                Call objFind.Execute(Replace:=Word.wdReplaceAll)
            Next
            
            ' 名前を付けてWordファイルを保存。
            docDoc.SaveAs2 "C:\Temp\賞状_" & Format(i + 1, "00_") & Join(DstArray, "_") & ".docx"
            
            ' ファイルを閉じる。
            docDoc.Close False
        Next
        
        ' 「Wordそのもの」を終了。
        objWord.Quit
        
        MsgBox "ファイル作成しました。"
End Sub