文字をランダムに入れ替えてみる。 - Infomentのブログ～Excel VBA奮闘記～

昨日は、ある範囲の「順番だけ」をランダムに入れ替えるユーザー定義関数を作成した。
infoment.hatenablog.com
そこで今日は、いよいよ、中身もランダムに入れ替えることに挑戦する。
f:id:Infoment:20181210221449p:plain

もともとは、はけたさんから紹介いただいた、こちらのサイトが切っ掛けだった。
jp.vuejs.org

こちらの、数字をシャッフルする機能が格好良くて、ぜひExcelでもやってみたいと思った。Excelで行って、何の意味があるかは置いといて。

といっても一昨日までに、ベース部分は作成済みだ。今回は、複数のテキストボックスを動かせるよう、少しだけ改造すればよい。移動先は、昨日作成した「ランダムに順序を入れ替える」辞書（連想配列）を適用する。

今回も、クラスモジュールを丸ごと掲載する。もし試す場合は、事前に「Microsoft Scripting Runtime」を参照設定して欲しい。

クラスモジュール（TextBoxClass）

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

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

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

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

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

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

' セルの文字からテキストボックスを作成。
Public Sub CellToTextbox(Optional moving_character_start_position As Long = 1)

    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)
    
    On Error Resume Next
    Dim i As Long
        For i = 1 To iMax
            If TargetRange.Item(i).Value <> "" Then
                OriginalCharacter(i) = TargetRange.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)
                    TargetRange.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 = msoAnchorMiddle
                    myTextBox(i).TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
                    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 TextboxToCell()
    Dim i As Long
        On Error Resume Next
        For i = 1 To iMax
            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 = .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

' GetShuffledOrderに基づき、移動後のセルを取得する。
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) = TargetRange.Item(TempDict(i))
    Next

End Sub

標準モジュール

クラス側で作りこんであるので、実行側はシンプルだ。
※今回は、選択範囲の文字列をセル単位でランダム移動させている。

Sub MoveTest()
    Dim TBC As TextBoxClass
    Set TBC = New TextBoxClass
    Set TBC.TargetRange = Selection
    
    Dim i As Long
    For i = 1 To 30
        TBC.GetDestinationRange
        TBC.CellToTextbox
        TBC.RandomMovingTextBox
        TBC.TextboxToCell
    Next
End Sub