「敢闘賞」はレイアウトが変わる件について

Excel VBA 作ってみた

先日まで、順位毎の賞状印刷用データを作成することに挑戦してきた。
infoment.hatenablog.com
今日も、先日の続きから。

試合の前日、担当の先生からの説明によれば、賞状のひな形は二つある
とのことだった。

  1. 優勝（一位）～三位まで用
  2. 敢闘賞（四位）用

理由を伺ったところ、次の説明があった。

「敢闘賞」だけ三文字であるため、それ用に文字サイズを調整した別ファイルを準備した。

なるほど、確かに毎回文字サイズを修正するのは大変だ。
ということで、順位によって転記するWordファイルを自動選択できるようにした。
また、使用環境でファイルパスが変わる場合もあるだろうから、ファイルパスは
シートに記載することとした。

Public Function SrcFilePath(i As Long) As String
    Select Case i
        ' 優勝～三位用ファイル。
        Case 0 To 2
            SrcFilePath = ThisWorkbook.Sheets(1).Range("B1")
            
        ' 敢闘賞（＝四位）用ファイル。
        Case 3
            SrcFilePath = ThisWorkbook.Sheets(1).Range("B2")
    End Select
End Function

Public Property Get DstFilePath() As String
    DstFilePath = ThisWorkbook.Sheets(1).Range("B3")
End Property

これに合わせ、マクロ内のファイルパス：ベタ打ち個所を修正したのがこちら。

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(SrcFilePath(i))
            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 DstFilePath & "\" & Format(i + 1, "00_") & Join(DstArray, "_") & ".docx"
            
            ' ファイルを閉じる。
            docDoc.Close False
        Next
        
        ' 「Wordそのもの」を終了。
        objWord.Quit
        
        MsgBox "ファイル作成しました。"
End Sub

それでは次回、いよいよまとめに入ります。

参考まで。