2022-12-06

再びトーナメント表作成 ② 前大会の入賞者を良い感じに分散したい

Excel VBA 作ってみた

昨日は、選手の人数からトーナメント表のサイズを求めるために、
常用対数を使ってみた。
infoment.hatenablog.com
今日は、前大会の入賞者が一回戦でぶつからないよう、良い感じに分散
させることに挑戦する。

以前トーナメント表作成マクロに挑戦した際は、

８人までの大会は組合せ決め打ち
９人以上の大会は指数関数などを用いて組合せ決定

という風に、非常に複雑なことを行っていた。しかし今回、改めて考えて
気が付いた。もっと簡単な方法があるのでは無いかと。

それは、

組合せを増やしたい場合は、既存の組合せをペロッとめくりコピーして、
片方を奇数に、片方を偶数にする

というもの。文字にすると「なんそれ！？」となるので、PowerPointで
動画を作ってみた。

これを繰り返せば、前大会の１位と２位は常に決勝戦でのみ対戦することに。
何回ペロッとめくれば良いかは、昨日求めた「トーナメントのサイズ」から
容易に求まる。例えば選手が１８人の場合、

１８人の選手が収まるトーナメントサイズは３２人である。
３２は２＾５であるから、５回ペロッとめくれば良い。

ことになる。

では、３２が２の５乗であることを求めるにはどうすればよいか。これは
LOG２関数があれば一発で求まるのだが、どうやら無いようなので、底の
変換公式で求めるとしよう。
manabitimes.jp

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

Function GetTournamentOrderArray(player_count As Long, _
                        Optional invers_flag As Boolean = False) As Variant
    
    ' 作業用配列。最終的に戻り値となる。
    Dim arr() As Variant
    ReDim arr(1 To 1)
    ' 初期値。選手が一人のとき。
        arr(1) = 1
        If player_count = 1 Then
            GetTournamentOrderArray = arr
            Exit Function
        End If
        
    ' WorksheetFunctionの表記短縮用。
    Dim Wf As WorksheetFunction
    Set Wf = WorksheetFunction
        
    ' 選手の数から求めるトーナメントサイズ。
    Dim TournamentSize As Long
        TournamentSize = 10 ^ (Wf.Ceiling_Math(Wf.Log10(player_count), Wf.Log10(2)))
    
    Dim i As Long
    Dim j As Long
    
    ' 選手の数に併せて大きくなるトーナメントの仮格納用配列。
    Dim TempArray As Variant
        ' 底の変換公式を用いて、配列を何回２倍するか求めている。
        For i = 1 To Wf.Log(TournamentSize) / Wf.Log(2)
            ReDim TempArray(1 To UBound(arr) * 2)
            For j = 1 To UBound(arr)
                ' 元の配列内の数値を、上から奇数で、下から偶数でセット。
                TempArray(j) = arr(j) * 2 - 1
                TempArray(UBound(TempArray) + 1 - j) = arr(j) * 2
            Next
            arr = TempArray
        Next
        
        ' 配列の最後を１位にしたい場合用。配列の順序をひっくり返す。
        If invers_flag Then
            For i = 1 To UBound(arr)
                arr(i) = TempArray(UBound(TempArray) - i + 1)
            Next
        End If
        
        GetTournamentOrderArray = arr

End Function

それでは早速、確認してみよう。

Sub Test()

    Dim arr As Variant
    Dim i As Long
        For i = 1 To 18
            arr = GetTournamentOrderArray(i, True)
        
            ' 貼り付けて確認。
            Cells(1, i).Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)
        Next

End Sub

確認した結果がこちら。

選手数に関わらず、条件分岐することなく作成できるようになった。
これも、前回のそれも、既に世の中に広く知られた方法なのだろう。
ぐぬぬ、もっと早く気づいていれば。

次回に続きます。

参考まで。

2022-12-05

再びトーナメント表作成 ① 常用対数が使えることに気づいた

Excel VBA 作ってみた

前回まで、賞状作成用のマクロについて紹介してきた。
infoment.hatenablog.com
実は先日の大会の後、「トーナメント作成ツール」についても相談を受けていた。
そういえば随分と前になるが、作ったことがあったっけ。

今回は、その焼き直しに挑戦するお話。

以下は、３年以上前に作成したトーナメント作成ツールだ。
infoment.hatenablog.com

今見返してみると、もっと簡単にできる部分もあることに気づく。
例えば、トーナメントのサイズを求める方法などだ。

シード選手が架空の相手に不戦勝すると考えた場合、選手数とトーナメントの
サイズは以下の関係となる。

１～２人のとき　２人
１～４人のとき　４人
１～８人のとき　８人
１～ｎ人のとき　？人

例えば１８人のとき、トーナメントのサイズを幾つにすればよいか？ぼんやりと
眺めていて、そういえば去年、長男と一緒にやった対数が使えることに気づいた。

まず、18の常用対数を求める。
$\log _{10}18\simeq 1.255273$
また、
$\log _{10}2\simeq 0.3010$
であるから、以下の不等式が成立する。
$\log _{10}2^{4} <\log _{10}18<\log _{10}2^{5}$
この $18$ を $2^5$ に切り上げる際は、ExcelなのでCEILING関数を使うことにした。
support.microsoft.com
この関数、一番近い基準値の倍数に切り上げてくれる。なんて便利なんだ。
実際に使用する数式は、このようになる。
$=CEILING.MATH(LOG10(18),LOG10(2))=1.50515$
従って最終的に、求めるトーナメントのサイズは以下の式で求まる。
$=10^{1.50515}=32$
という訳で、人数に関係なく同じ式で対応が可能だったわけだ。

こんなシンプルな方法があったとは。ぐぬぬ、もっと早く気づいていれば。

次回に続きます。

参考まで。

2022-11-30

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

Excel VBA 作ってみた

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

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

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

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

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

以上を踏まえて作成したクラスモジュール（クラス名：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

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

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

参考まで。

2022-11-28

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

Excel VBA 作ってみた

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

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

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

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

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

なるほど、確かに毎回文字サイズを修正するのは大変だ。
ということで、順位によって転記する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

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

参考まで。

2022-11-21

賞状データ作成

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

確認した結果が ↓ こちら。

↓ このように無事、各選手のデータを作成することができた。

上手くいった？いえいえ、何事にも「例外」は付きものなわけで。

次回に続きます。

2022-11-20

無色無味無臭の毒を除去：VBAとワークシートのTrim関数の違い

Excel VBA 作ってみた

先日から、「賞状印刷用データ作成マクロ」に挑戦している。
前回は、一位から四位までの選手の氏名を取得する関数を作成してみた。
infoment.hatenablog.com
今日も、前回の続きから。
ja.wikipedia.org
※毒：Poisonとポアソン：Poissonを絡めた駄洒落。今回の内容にポアソン分布等は登場しませんので、悪しからずｍ（＿＿）ｍ。

前回登場したトーナメント表について。

こちらに使用される選手の名前は、各支部から提出される名簿を元に作成される。
初見で読めない名前も散見されるため、名簿を見ながらの転記は非常に危険だ。
そこで、トーナメント表作成の際は、提出されたデータからそのままコピペする。
しかし、全ての支部の先生方が、同じ方法でデータを作成くださるとは限らない。
特に、スペースの使い方が複数あったりする。

例）

山田花子　← 姓と名の間に、半角スペースが一つある。
山田花子　← 姓と名の間に、半角スペースが二つある。
山田　花子　← 姓と名の間に、全角スペースが一つある。
山田花子　← 名前の後に、半角スペースが一つある。

上記1. のパターンを想定してマクロを作成して、それ以外のものが偶にあって
上手くいかないケースを、誰もが一度は体験しているのではないだろうか。

特に4. の、文字列最後の半角スペースの存在は、まず見た目で気づけない。
業務中、これに何度か苦しめられたことがある。その気づけなさ具合から、
私は個人的にこれを「無色無味無臭の毒」と呼んでいる。

文字列前後の空白を取り除くには、Trim関数が便利だ。ただし、VBAとワーク
シート関数では挙動が少し違うので、注意が必要になる。

VBAの場合：文字列前後のスペース文字を除去（半・全角を問わず）。
ワークシートの場合：文字列前後のスペース文字を除去。文字列内に連続する
スペース文字がある場合、連続するグループ毎に一文字残してこれも除去。
半・全角が混在する場合、半角スペースが優先的に残される（らしい）。

Sub テスト()
    Dim Src As String
        Src = "   　山田     　    花子    "
        MsgBox "元の文字：" & Src & vbNewLine & _
               "ＶＢＡ：" & Trim(Src) & vbNewLine & _
               "ワークシート：" & WorksheetFunction.Trim(Src)
End Sub

両者に一長一短ありそうで、状況に合わせて使い分けることが望ましい。
今回は上記1. のパターンにしたいので、以下の作戦で処理する。

姓名内のスペース文字を、全て半角スペースに置換する。
ワークシートのTrim関数で、前後の半角スペースがあれば除去。

↓ 昨日の「生徒の名前」関数を改修。

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

傾向として全文字数が３の場合、スペース文字で調整されることが多いようだ。

次回は、賞状用データ（Word）を作成します。

参考まで。

2022-11-19

選んだ順で一位から四位の名前を取得したい

Excel VBA 作ってみた

前回は、「小学３年生女子組手」などを「小学生三年女子　組手の部」のように
一定のルールで成形することに挑戦した。
infoment.hatenablog.com
今日は、前回の続きから。

前回も少し述べたように、一連の作業は賞状印刷用データを作成するためのもの。
賞状のレイアウトに合わせて調整されたWordファイルがあって、そこに下記情報を
反映・印刷する。各項目の後ろには、今までの運用を記載。

部門　←　手入力
順位　←　手入力
名前　←　Excel側のトーナメントで選択コピーののち、Wordでペースト

↓ こんな感じのExcelシートから、一位～四位までの情報を得る必要がある。

試合は各コートで同時に始まり、終わり次第表彰となるので、試合終わりには
大至急データを作成して印刷する必要があった（今まで）。そこで、その作業
支援をExcel VBAでできないかと考えた次第。

作戦は、こんな感じだ。

一位から四位までの選手を、Excel上で順に選択する。
マクロ実行。
一位から四位までの選手名と部門名、順位を反映した賞状用Word作成。
各データの内容を確認ののち、手動で印刷。

最後に手動で印刷するのは、レイアウトの乱れが無いかを確認するため。
中には日本在住の外国人のお子さんもおられて、例えば
「ジャン・リュック・ピカード」さん
が優勝した場合、「山田花子」さん用にレイアウト調整された賞状データは
見直しが必要なわけで。折角優勝したのだから、奇麗にレイアウトを整えて
渡してあげたい。

まず、選手の名前取得について。

For Each 変数 In Selection

でループすると、選択した順に処理が進む。これを利用して、選手の名前を
入賞順に取得することとした。

Function 生徒の名前() As Variant
    Dim r As Range
    ' 名前格納用配列。
    Dim arr As Variant
        arr = Array()
        
    ' 選んだ順に配列に格納。
    ' 団体戦などは３チームしか出ない場合もあるため、配列のサイズは可変とする。
        For Each r In Selection
            ' セルが結合されている場合に備えて、空白判定を行う。
            If r <> vbNullString Then
                ReDim Preserve arr(UBound(arr) + 1)
                arr(UBound(arr)) = r.Value
            End If
        Next
        
        生徒の名前 = arr
End Function

次に順位について、１～４位を以下のとおり変換する必要がある。

１位　⇒　優勝
２位　⇒　二位
３位　⇒　三位
４位　⇒　敢闘賞

４位は四位ではなく、ここでは敢闘賞としている。よく頑張ったと労いたい。

Public Function 順位(i As Long) As String
    ' 選んだ順で順位を決定。
    Select Case i
        Case 0: 順位 = "優勝"
        Case 1: 順位 = "二位"
        Case 2: 順位 = "三位"
        Case 3: 順位 = "敢闘賞"
    End Select
End Function

以上を組み合わせて、テストしてみよう。

Sub テスト()
    Dim arr(0 To 3) As Variant
    Dim i As Long
        For i = 0 To 3
            arr(i) = 順位(i) & "：" & 生徒の名前(i)
        Next
        
        MsgBox Join(arr, vbNewLine)

End Sub

結果がこちら。※選手の名前は、Ctrlキーを押しながら選択している。

上手くいった？いえいえ、何事にも「例外」は付きものなわけで。

次回に続きます。