選択範囲が飛び飛びでもランダムに移動できるようにする

昨日は、指定範囲内の文字をランダムに入れ替えてみた。
infoment.hatenablog.com
お気づきの方も居られると思うが、昨日のコードには穴がある。選択範囲が飛び飛びの場合、正しく動作しないのだ。
そこで今日は「三つ目のやりたいこと」のために、まずは、選択範囲が飛び飛びでもランダムに移動できるようにする。

まず昨日までのマクロでは、選択範囲の中の各セルを指定するために、Itemプロパティを用いた。エッセンスを抜き出すと、こんな感じだ。

Sub RangeItemTest()
    Dim i As Long: i = 1
    For i = 1 To Selection.Count
        Selection.Item(i) = i
    Next
End Sub

結果は、例えばこのようになる。

縦と横では、横が優先されるようだ。では、飛び飛びに選択するとどうなるか。結果から言えば、このようになる。

itemプロパティでは、選択範囲に関係なく縦に並んでしまった。これでは飛び飛びの範囲でランダムに動かそうと思っても上手くいかない。さて、どうしたものか。

ということで今回は、安易に「コレクションに突っ込む」ことで解決してみた。

Sub RangeItemTest()
    Dim col As Collection
    Set col = New Collection
    
    Dim r As Range
    For Each r In Selection
        col.Add r
    Next

    Dim i As Long: i = 1
    For i = 1 To col.Count
        col.Item(i) = i
    Next
End Sub

結果はこちら。

一応、選択した範囲だけを辿ることが出来た。

これを、昨日のマクロに反映したものが、こちらになる。

クラスモジュール（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

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

結果は、こんな感じだ。

長くなってきたので、明日に続きます。

参考まで。