選んだ順で一位から四位の名前を取得したい - Infomentのブログ～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