賞状作成用マクロのクラス化（最終回）

Excel VBA 作ってみた

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

実は大会当日の朝に突貫で作成したマクロは、もっと作りが粗かった。
しかしそれでも、何とかその日の大会運営を円滑に行うことができた。
考えてみると、仕事を除けば、私の作成したマクロが社会貢献できた
初めての事例ではなかろうか。また嬉しからずや。

ということで、前回までの分で完成としても良いのだが、今後継続して
使用する場合の汎用性を考えて更に作りこみ、改めて先生に渡すことに
した。

今回考慮すべきと考えた点は、以下のとおり。

  1. 当日実行するマクロは、極力シンプルに 且つ 解り易いものに。
  2. 賞状のひな形データ有り無しチェックを追加。
  3. 作成した印刷用データの保存フォルダ有り無しチェックを追加。
  4. 優勝から敢闘賞まで、全て異なるひな形の指定確認を可能にする。
    ただし、二位以降は省略した場合、前の順位と同じひな形を使用する。

以上を踏まえて作成したクラスモジュール（クラス名：Certificate）

Option Explicit

' 順位指定用。
Public Enum enRank
    en1st
    en2nd
    en3rd
    en4th
    [_eLast]
End Enum

' 印字用ひな形データ格納パス：一位～四位。
Public SrcFilePath_1 As String
Public SrcFilePath_2 As String
Public SrcFilePath_3 As String
Public SrcFilePath_4 As String
' 作成した印字用データ格納用フォルダパス。
Public DstFilePath As String
' 一位～四位の選手の名前がセットされた範囲。
Public PlayerNameRange As Range

' 印刷用ひな形データ格納パス取得。
Private Property Get SrcFilePath() As Variant
    Dim arr(en1st To en4th) As Variant
        ' 二位以降は指定が無ければ、前の順位と同じひな形を使用する。
        arr(en1st) = SrcFilePath_1
        If SrcFilePath_2 = vbNullString Then arr(en2nd) = arr(en1st) Else arr(en2nd) = SrcFilePath_2
        If SrcFilePath_3 = vbNullString Then arr(en3rd) = arr(en2nd) Else arr(en3rd) = SrcFilePath_3
        If SrcFilePath_4 = vbNullString Then arr(en4th) = arr(en3rd) Else arr(en4th) = SrcFilePath_4
        SrcFilePath = arr
End Property

Private Sub Class_Initialize()
    ' 一位～四位の選手の名前が入力された範囲を取得。
    ' 初期値は、クラスが初期化された際に選択された範囲とする。
    ' ※後で上書き可。
    Set PlayerNameRange = Selection
End Sub

Public Property Get CheckValues() As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim i As Long
        ' 各印字用ひな形データの存在確認。
        For i = enRank.en1st To enRank.en4th
            If Not FSO.FileExists(SrcFilePath(i)) Then
                CheckValues = False
                Exit Property
            End If
        Next
        
        ' 作成した印字用データ格納フォルダの存在確認。
        If FSO.FolderExists(DstFilePath) Then CheckValues = True
End Property

Private Function GetRankName(i As enRank) As String
    ' 選んだ順で順位を決定。
    Select Case i
        Case en1st: GetRankName = "優勝"
        Case en2nd: GetRankName = "二位"
        Case en3rd: GetRankName = "三位"
        Case en4th: GetRankName = "敢闘賞"
    End Select
End Function

Sub MakeCertificate()
    ' Excelで選んだ人の名前を格納するための配列。
    Dim arr As Variant
        arr = GetPlayerName
        
    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) = EditCategoryName(ActiveSheet.Name)
    ' Word内の文字列。
    Dim docDoc As Word.Document
    ' 文字列の置換。
    Dim objFind As Word.Find
    Dim i As Long
    Dim j As Long
        For i = en1st To UBound(arr)
            DstArray(1) = GetRankName(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

' 入賞した選手の名前を取得。
Private Function GetPlayerName() As Variant
    Dim r As Range
    ' 名前格納用配列。
    Dim arr As Variant
        arr = Array()
        
    ' 選んだ順に配列に格納。
    ' 団体戦などは３チームしか出ない場合もあるため、配列のサイズは可変とする。
        For Each r In PlayerNameRange
            ' セルが結合されている場合に備えて、空白判定を行う。
            If r <> vbNullString Then
                ReDim Preserve arr(UBound(arr) + 1)
                ' 余分なスペース文字を除去したのち、配列に格納する。
                arr(UBound(arr)) = WorksheetFunction. _
                                    Trim(Replace(r.Value, "　", " "))
            End If
        Next
        
        GetPlayerName = arr
End Function

' 部門名称を賞状に合わせて編集。
Private Function EditCategoryName(src As String) As String
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        myReg.Pattern = "(小学|中学|高校|一般)生?([0-9０-９]?)年?生?(男子|女子)(団体)?(形|組手)"
    Dim MC As Object
    Dim SM As Object
        If Not myReg.test(src) Then
            EditCategoryName = src
            Exit Function
        End If
        
    Set MC = myReg.Execute(src)
    Set SM = MC(0).SubMatches
    
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        ' 「一般」以外は、「小学生」「中学生」「高校生」で表記統一。
        Select Case SM(0)
            Case "一般": Dict(1) = SM(0)
            Case Else: Dict(1) = SM(0) & "生"
        End Select
        ' 高校生は学年表記無し。
        ' 表記は漢数字で「〇年」とする（〇年生としない）。
        If SM(0) <> "高校" And SM(1) <> vbNullString Then
            Dict(1) = Dict(1) & _
                      WorksheetFunction.Text(SM(1), "[DBNum1]0年")
        End If
        
        ' 男子または女子を追加。
        Dict(1) = Dict(1) & SM(2)
        
        ' 団体表記があれば追加。
        If SM(3) <> vbNullString Then
            Dict(1) = Dict(1) & SM(3)
        End If
        
        ' 形の部／組手の部
        Dict(2) = SM(4) & "の部"
        
        EditCategoryName = Join(Dict.Items, "　")
End Function

かなり回りくどい部分も出来てしまったが、これにより実際に作成実行する
個所はシンプルにできた。

Sub 賞状作成()
    With New VBAProject.Certificate
        ' 優勝者～三位用Wordデータのひな形フルパス。
        .SrcFilePath_1 = Sheets(1).Range("B1")
        
        ' 敢闘賞用Wordデータのひな形フルパス。
        .SrcFilePath_4 = Sheets(1).Range("B2")
        
        ' 作成したWordデータの保存先フォルダパス。
        .DstFilePath = Sheets(1).Range("B3")
        
        ' 上記の内容確認。もし問題なければ賞状作成。
        If .CheckValues Then
            .MakeCertificate
        Else
            MsgBox "指定されたデータまたはフォルダが存在しないため､処理を中断します｡ "
        End If
    End With
End Sub

改めて使ってもらい、要望があればまた見直すこととしよう。

というわけで、このシリーズはこれでおしまい。

参考まで。