先日、ListViewコントロールを使ってあれこれしようと考えたが、結局上手くいかなかった。そこでこのネタは、とりあえずお蔵入り。
閑話休題、先日作成した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 ExchangeStrings()
Dim TBC As TextboxClass
Set TBC = New TextboxClass
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
Dim iMax As Long
iMax = Col.Count / 2
Dim myVerticalAlignment As Long
Dim myHorizontalAlignment As Long
For i = 1 To iMax
If Col.Item(i).Value <> vbNullString Or Col.Item(i + iMax).Value <> vbNullString Then
Set TBC.TargetRange = Union(Col.Item(i), Col.Item(i + iMax))
myVerticalAlignment = Selection.Item(i).VerticalAlignment
myHorizontalAlignment = Selection.Item(i).HorizontalAlignment
TBC.ExchangeString
TBC.TargetRange.VerticalAlignment = myVerticalAlignment
TBC.TargetRange.HorizontalAlignment = myHorizontalAlignment
End If
Next
End Sub
選択範囲の文字列を入れ替えるマクロだ。ただ入れ替えるだけだと面白くないので、入れ替えの様子を見える化している。難点は以下の二つ。
- 数が多いと、面白さより「待ちの苛立ち」が募るかも。
- 入れ替える範囲を正しく選択しないと、正しい結果が得られない。
試してみると、こんな感じだ。
お察しの通り、見ての通り、実用性は殆どない。
まあ、お遊びということで。
参考まで。