指定範囲の文字列の入れ替え その２

昨日は、かつて作成したTextBoxClassで遊んだ例を紹介した。
infoment.hatenablog.com
今日は時間が無いので、同クラスモジュールをそのまま使用した、もう一つの遊びを紹介。

こちらでは、指定範囲の文字列を、ランダムに入れ替えている。

◆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)

    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 = 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 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
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 = .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

Sub RandomMoveTest()
    Dim TBC As TextboxClass
    Set TBC = New TextboxClass
    Set TBC.TargetRange = Range("B2:C6")
    
    Dim i As Long
    For i = 1 To 10
        TBC.GetDestinationRange
        TBC.CellToTextbox
        TBC.RandomMovingTextBox
        TBC.TextboxToCell
    Next
End Sub

これをこちらで動かすと、こうなる。

このように、２つのチームを無作為に作成する際、見た目が少しだけ面白いかも。

参考まで。