マンゴー杯への挑戦

本日、以下の記事を拝読した。
koroko.hatenablog.com

今回VBAであみだくじを作っていたら、「そもそもあみだくじにする意味あるのかな？公平なら何でも良くない？」と疑問が沸いた。
業務でも、こういうのいっぱいあると思う。
そもそも、何の為にそれをやるのか。
今までは手作業だったからそのやり方が最善だったけど、本当は何がしたいのか。
マクロを作っていると、本当はどうなんだろう？って思ってくる。

この意見に、少なくとも個人的には反論の余地が無い。まさに仰る通り。

今回の抽選のマクロ、コロ子は間借り方式で作ったけど、こういうのの考え方は人それぞれ。
「自分ならこうする！」と言うのがあれば、ぜひコメントください！

よし、やってみよう！

一瞬で勝敗が決しては、無味乾燥なものとなってしまう。そこで今回は「マンゴー杯」と称して、当選者３名が出るまで一人ずつ落選する様子を、視覚的に表現してみた。

まず準備するのは、以前にも紹介した ↓ こちらのクラスモジュール。
※長ったらしいので、折りたたんであります。

◆TextBoxClass（クリックで展開）◆

Option Explicit

Public TargetRange As Range
Public DestinationRange As Variant
Public myTextBox As Variant
Public OriginalCharacter As Variant

Public Sub ExchangeString()
    If TargetRange.Count <> 2 Then
        MsgBox "値を入れ替えたいセルを二つ選択して、" & vbNewLine & _
               "再度実行してください。"
        Exit Sub
    End If
    
    ReDim DestinationRange(1 To iMax)
    Dim R As Range
    Dim i As Long: i = 2
    For Each R In TargetRange
        Set DestinationRange(i) = R
        i = i - 1
    Next
    
    Call CellToTextbox
    Call MovingTextBox
    Call TextboxToCell
    
End Sub

Public Property Get iMax() As Long
    iMax = TargetRange.Count
End Property

Public Function TargetCol() As Collection
    Dim TempCol As Collection
    Set TempCol = New Collection
    Dim R As Range
        For Each R In TargetRange
            TempCol.Add R
        Next
    Set TargetCol = TempCol
End Function

Private Function myLeft(myIndex As Long) As Double
    myLeft = TargetCol.Item(myIndex).Left
End Function

Private Function myTop(myIndex As Long) As Double
    myTop = TargetCol.Item(myIndex).Top
End Function

Private Function myWidth(myIndex As Long) As Double
    myWidth = TargetCol.Item(myIndex).Width
End Function

Private Function myHeight(myIndex As Long) As Double
    myHeight = TargetCol.Item(myIndex).Height
End Function

Public Sub CellToTextbox(Optional moving_character_start_position As Long = 1, _
                         Optional vertical_anchor As Office.MsoVerticalAnchor = msoAnchorMiddle, _
                         Optional holizontal_alignment As MsoParagraphAlignment = msoAlignLeft)

    ReDim OriginalCharacter(1 To iMax)
    ReDim myTextBox(1 To iMax)

    Dim RemainingCharacter() As Variant
    ReDim RemainingCharacter(1 To iMax)
    Dim MovingCharacter() As Variant
    ReDim MovingCharacter(1 To iMax)
    
    Dim i As Long
        For i = 1 To iMax
            If TargetCol.Item(i).Value <> "" Then
                OriginalCharacter(i) = TargetCol.Item(i)

                Select Case moving_character_start_position
                    Case 1
                        RemainingCharacter(i) = ""
                        MovingCharacter(i) = OriginalCharacter(i)
                    Case Is > Len(OriginalCharacter(i))
                        RemainingCharacter(i) = OriginalCharacter(i)
                        MovingCharacter(i) = ""
                    Case Else
                        RemainingCharacter(i) = Left(OriginalCharacter(i), moving_character_start_position - 1)
                        MovingCharacter(i) = WorksheetFunction.Rept("　", Len(RemainingCharacter(i))) & _
                                          Mid(OriginalCharacter(i), moving_character_start_position)
                End Select
                
                Set myTextBox(i) = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                            myLeft(i), myTop(i), myWidth(i), myHeight(i))
                    myTextBox(i).TextFrame2.TextRange.Characters.Text = MovingCharacter(i)
                    TargetCol.Item(i).Value = RemainingCharacter(i)
                    myTextBox(i).TextFrame2.TextRange.Font.NameComplexScript = TargetRange.Item(i).Font.Name
                    myTextBox(i).TextFrame2.TextRange.Font.NameFarEast = TargetRange.Item(i).Font.Name
                    myTextBox(i).TextFrame2.TextRange.Font.Name = TargetRange.Item(i).Font.Name
                    myTextBox(i).TextFrame2.TextRange.Font.Size = TargetRange.Item(i).Font.Size
                    myTextBox(i).TextFrame2.VerticalAnchor = vertical_anchor
                    myTextBox(i).TextFrame2.TextRange.ParagraphFormat.Alignment = holizontal_alignment
                    myTextBox(i).TextFrame2.MarginLeft = 2.5
                    myTextBox(i).Line.Visible = msoFalse
                    myTextBox(i).Fill.Visible = msoFalse
            End If
        Next
End Sub

' テキストボックスをランダムに移動させる。
Public Sub RandomMovingTextBox(Optional fade_out_flag As Boolean = False)
    '一回の移動を細分化する回数。
    Dim MoveCount As Long: MoveCount = 40
    ' 移動の始点。
    Dim x1() As Double: ReDim x1(1 To iMax)
    Dim y1() As Double: ReDim y1(1 To iMax)
    ' 移動の終点。
    Dim x2() As Double: ReDim x2(1 To iMax)
    Dim y2() As Double: ReDim y2(1 To iMax)
    ' 細分化した一回の移動距離。
    Dim dx() As Double: ReDim dx(1 To iMax)
    Dim dy() As Double: ReDim dy(1 To iMax)
    
    Dim color_index As Integer
    
    On Error Resume Next
    Dim m As Long
    Dim i As Long
    For m = 0 To MoveCount - 1
        For i = 1 To iMax
            x1(i) = myTextBox(i).Left
            y1(i) = myTextBox(i).Top
            x2(i) = DestinationRange(i).Left
            y2(i) = DestinationRange(i).Top
            dx(i) = (x2(i) - x1(i)) / (MoveCount - m)
            dy(i) = (y2(i) - y1(i)) / (MoveCount - m)
            myTextBox(i).Left = myTextBox(i).Left + dx(i)
            myTextBox(i).Top = myTextBox(i).Top + dy(i)
            
            If fade_out_flag = True Then
                color_index = 255 * (1 - m) / (1 - MoveCount)
                
                myTextBox(i).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = _
                    RGB(color_index, color_index, color_index)
            End If
        Next
        Application.Wait [now()+"0:00:00.001"]
    Next
End Sub

Public Sub MovingTextBox(Optional fade_out_flag As Boolean = False)
    '一回の移動を細分化する回数。
    Dim MoveCount As Long: MoveCount = 40
    ' 移動の始点。
    Dim x1() As Double: ReDim x1(1 To iMax)
    Dim y1() As Double: ReDim y1(1 To iMax)
    ' 移動の終点。
    Dim x2() As Double: ReDim x2(1 To iMax)
    Dim y2() As Double: ReDim y2(1 To iMax)
    ' 細分化した一回の移動距離。
    Dim dx() As Double: ReDim dx(1 To iMax)
    Dim dy() As Double: ReDim dy(1 To iMax)
    
    Dim color_index As Integer
    
    Dim m As Long
    Dim i As Long
    For m = 0 To MoveCount - 1
        For i = 1 To iMax
            On Error Resume Next
            x1(i) = myTextBox(i).Left
            y1(i) = myTextBox(i).Top
            x2(i) = DestinationRange(i).Left
            y2(i) = DestinationRange(i).Top
            dx(i) = (x2(i) - x1(i)) / (MoveCount - m)
            dy(i) = (y2(i) - y1(i)) / (MoveCount - m)
            myTextBox(i).Left = myTextBox(i).Left + dx(i)
            myTextBox(i).Top = myTextBox(i).Top + dy(i)
            
            If fade_out_flag = True Then
                color_index = 255 * (1 - m) / (1 - MoveCount)
                
                myTextBox(i).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = _
                    RGB(color_index, color_index, color_index)
            End If
        Next
        Application.Wait [now()+"0:00:00.001"]
    Next
    
    If fade_out_flag = True Then
        For i = 1 To iMax
            myTextBox(i).Delete
        Next
    End If
    
End Sub

Public Sub TextboxToCell()
    Dim i As Long
        For i = 1 To iMax
            On Error Resume Next
            With myTextBox(i).TextFrame2
                DestinationRange(i).Value = .TextRange.Characters.Text
                DestinationRange(i).Font.Name = .TextRange.Font.Name
                DestinationRange(i).Font.Size = .TextRange.Font.Size
                DestinationRange(i).VerticalAlignment = xlCenter
                DestinationRange(i).HorizontalAlignment = xlCenter
'                DestinationRange(i).VerticalAlignment = .VerticalAnchor
'                DestinationRange(i).HorizontalAlignment = .TextRange.ParagraphFormat.Alignment
            End With
            myTextBox(i).Delete
        Next
End Sub

Private Function GetShuffledOrder() As Dictionary
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    Dim i As Long
        For i = 1 To iMax
            Do
                Dim TempNumber As Long
                    TempNumber = Rnd * (iMax + 1)
                    If TempNumber >= 1 And TempNumber <= iMax And _
                       Dict.Exists(TempNumber) = False Then
                        Dict(TempNumber) = i
                        Exit Do
                    End If
            Loop
        Next
    
    Dim Dict2 As Dictionary
    Set Dict2 = New Dictionary
    Dim myKey As Variant
    For Each myKey In Dict.Keys
        Dict2(Dict(myKey)) = myKey
    Next
    
    Set GetShuffledOrder = Dict2
End Function

Public Sub GetDestinationRange()

    ReDim DestinationRange(1 To iMax)

    Dim TempDict As Dictionary
    Set TempDict = GetShuffledOrder

    Dim i As Long
    For i = 1 To iMax
        Set DestinationRange(i) = TargetCol.Item(TempDict(i))
    Next

End Sub

Public Sub GetDestinationRange_2(destination_range As Range)

    ReDim DestinationRange(1 To iMax)

    Dim TempDict As Dictionary
    Set TempDict = GetShuffledOrder
    
    Dim dx As Long
        dx = destination_range.Range("A1").Row - TargetRange.Range("A1").Row
    Dim dy As Long
        dy = destination_range.Range("A1").Column - TargetRange.Range("A1").Column

    Dim i As Long
    For i = 1 To iMax
        Set DestinationRange(i) = TargetCol.Item(TempDict(i)).Offset(dx, dy)
    Next

End Sub

これを利用して、作成したマクロがこちら。

Sub MangoCup()
    Dim TBC As TextBoxClass
    Set TBC = New TextBoxClass
    
    ' 元となる名簿の範囲。
    Dim SourceRange As Range
    Set SourceRange = Range("A5:A11")
    
    ' 抽選する名簿の範囲。
    ' 抽選するたびに変更される。
    Dim tempRange As Range
    Set tempRange = SourceRange
    
    ' 最後に元の箇所へ名簿を復元するための配列。
    Dim arr() As Variant
        arr = SourceRange
        
    ' 当選者数。
    Dim WinningCount As Long
        WinningCount = Range("B2").Value
    Dim i As Long
    
    ' 予選の回数。
    Dim iMax As Long
        iMax = SourceRange.Count - WinningCount
    
    ' マンゴーの数になるまで、毎回一人ずつ脱落させる。
    For i = 0 To iMax
        If i = iMax Then
            tempRange.Cells(0, 2) = "当選者"
        Else
            tempRange.Cells(0, 2) = "残念！"
        End If
    
        Set TBC.TargetRange = tempRange
        
        ' 名前の移動先をランダムに決定。
        TBC.GetDestinationRange_2 tempRange.Offset(, 1)
        
        ' セルからテキストボックスへ転記。
        TBC.CellToTextbox
        
        ' テキストボックスを移動させる。
        TBC.RandomMovingTextBox
        
        ' テキストボックスの値をセルへ転記。
        TBC.TextboxToCell
        
        ' テキストボックスを削除。
        ' 本来は自動で消える設定だが、動きがぎこちなかったので
        ' 念押しで最後に全て削除する。
        ActiveSheet.Shapes.SelectAll
        Selection.Delete
    
        ' １個残しの場合エラーとなるため、エラー無視のおまじない。
        On Error Resume Next
        
        ' 次の予選メンバーを決める。
        Set tempRange = tempRange.Offset(, 1).Resize(tempRange.Count - 1)
    Next
    
    ' 最初の名簿を返す。
    SourceRange = arr
End Sub

結果、このようになった。

最後まで自分が残るかどうか、ドキドキ感満載で楽しめること間違いなし。
でも正直、効果は未知数です。

参考まで。