テキストボックスの文字をセルに入力してみる - Infomentのブログ～Excel VBA奮闘記～

昨日は、セルに入力した文字列でテキストボックスを作成することに挑戦した。
infoment.hatenablog.com

今日は更に、以下に挑戦する。

作成したテキストボックスを、指定セルまで移動させる。
作成したテキストボックスの内容を、指定セルに転記する。
その際、テキストボックス事態は削除する。

f:id:Infoment:20181207225357p:plain

昨日作成した内容を少し変更し、以下の３つを準備した。

サブプロシージャ名	機能
CellToTextbox	セルの記載内容からテキストボックスを作成
MovingTextBox	テキストボックスを、指定セルまで移動
TextboxToCell	テキストボックスの記載内容を、指定セルに転記

実際のコードが、こちらになる。

クラスモジュール（TextBoxClass）

Option Explicit
Public TargetRange As Range
Public DestinationCell As Range
Public myTextBox As Shape

Private Property Get myLeft() As Double
    myLeft = TargetRange.Left
End Property

Private Property Get myTop() As Double
    myTop = TargetRange.Top
End Property

Private Property Get myWidth() As Double
    myWidth = TargetRange.Width
End Property

Private Property Get myHeight() As Double
    myHeight = TargetRange.Height
End Property

Public Sub CellToTextbox()
    If TargetRange = "" Then Exit Sub
    Set myTextBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                myLeft, myTop, myWidth, myHeight)
        myTextBox.TextFrame2.TextRange.Characters.Text = TargetRange.Value
        myTextBox.TextFrame2.TextRange.Font.NameComplexScript = TargetRange.Font.Name
        myTextBox.TextFrame2.TextRange.Font.NameFarEast = TargetRange.Font.Name
        myTextBox.TextFrame2.TextRange.Font.Name = TargetRange.Font.Name
        myTextBox.TextFrame2.TextRange.Font.Size = TargetRange.Font.Size
        myTextBox.TextFrame2.VerticalAnchor = msoAnchorMiddle
        myTextBox.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
        myTextBox.TextFrame2.MarginLeft = 1.5
        myTextBox.Line.Visible = msoFalse
        myTextBox.Fill.Visible = msoFalse
End Sub

Public Sub MovingTextBox()
    '一回の移動を細分化する回数。
    Dim iMax As Long: iMax = 200
    ' 移動の始点。
    Dim x1 As Double: x1 = myTextBox.Left
    Dim y1 As Double: y1 = myTextBox.Top
    ' 移動の終点。
    Dim x2 As Double: x2 = DestinationCell.Left
    Dim y2 As Double: y2 = DestinationCell.Top
    ' 細分化した一回の移動距離。
    Dim dx As Double: dx = (x2 - x1) / iMax
    Dim dy As Double: dy = (y2 - y1) / iMax
    
    Dim i As Long
        For i = 1 To iMax
            myTextBox.Left = myTextBox.Left + dx
            myTextBox.Top = myTextBox.Top + dy
            Application.Wait [now()+"0:00:00.001"]
        Next

End Sub

Public Sub TextboxToCell()
    With myTextBox.TextFrame2
        DestinationCell.Value = .TextRange.Characters.Text
        DestinationCell.Font.Name = .TextRange.Font.Name
        DestinationCell.Font.Size = .TextRange.Font.Size
        DestinationCell.VerticalAlignment = .VerticalAnchor
        DestinationCell.HorizontalAlignment = .TextRange.ParagraphFormat.Alignment
    End With
    myTextBox.Delete
End Sub

ワークシートのチェンジイベントがこちら。今回は、記入したセルから下に10，右に5つオフセットさせてみた。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Value = "" Then Exit Sub

    Dim TBC As TextBoxClass
    Set TBC = New TextBoxClass
    Set TBC.TargetRange = Target
    Set TBC.DestinationCell = Target.Offset(10, 5)
    
    Application.EnableEvents = False
    TBC.CellToTextbox
    Target = ""
    TBC.MovingTextBox
    TBC.TextboxToCell
    Application.EnableEvents = True
End Sub