Copy from cell to textbox and maintain all formatting with vba

问题

I need to be able to copy all data entered in a cell and copy it to a textbox. The text is a mixture of different font styles, including colours, bold, italic, and underlined text.

The user will then be able to enter more information onto the textbox, using different styles etc.

The hope from there is to be able to use vba to copy back to the original cell from the textbox.

The rationale is to allow the user to be able to type quite lengthy notes without the constraints of a cell. I am open to thinking of an embedded object (word). But I could not figure how to do this either.

I found this code which helped posted by David, but it does not include code relating to font colour for example. When I try to add it it throws and error.

Here is the code I found:

Sub passCharToTextbox()

'select Textbox 1:
ActiveSheet.Shapes.Range(Array("Textbox 1")).Select

'set text:
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = ActiveCell.Value

'loop through characters in original cell:
For i = 1 To Len(ActiveCell.Value)

    'add bold/italic to the new character if necessary:
    If ActiveCell.Characters(i, 1).Font.Bold = True Then
        Selection.ShapeRange(1).TextFrame2.TextRange.Characters(i, 1).Font.Bold = True
    Else
        Selection.ShapeRange(1).TextFrame2.TextRange.Characters(i, 1).Font.Bold = False
    End If
    If ActiveCell.Characters(i, 1).Font.Italic = True Then
        Selection.ShapeRange(1).TextFrame2.TextRange.Characters(i, 1).Font.Italic = True
    Else
        Selection.ShapeRange(1).TextFrame2.TextRange.Characters(i, 1).Font.Italic = False
    End If

Next i

End Sub

If anyone can help I would be really grateful.

回答1:

Perhaps this is what you need:

For it to work, make sure you select the correct activeCell and the "textbox 1" exist
Here are some other options: TextboxUnderline
Call CopyCelltoTextbox to run macro!

Sub passCharToTextbox()
   CopycellFormat ActiveCell
End Sub
Private Sub CopycellFormat(cell As Range)
If Trim(cell(1, 1).Value) = vbNullString Then MsgBox ("select only cell / not emptycell"): Exit Sub
Dim textrange As TextRange2, tbox1 As Shape, fontType As Font2
    With ActiveSheet
    On Error Resume Next: Err.Clear 'check if Textbox 2 exist
    Set tbox1 = .Shapes("Textbox 2"): Set textrange = tbox1.TextFrame2.textrange
    textrange.Characters.Text = cell.Value
    If Err.Number > 0 Then MsgBox ("Not found Textbox 2")

    For i = 1 To Len(cell.Value)
        Set fontType = textrange.Characters(i, 1).Font
        With cell.Characters(i, 1)
            fontType.Bold = IIf(.Font.Bold, True, 0)                    'add bold/
            fontType.Italic = IIf(.Font.Italic, True, 0)                'add italic/
            fontType.UnderlineStyle = IIf(.Font.Underline > 0, msoUnderlineSingleLine, msoNoUnderline) 'add underline/
        textrange.Characters(i, 1).Font.Fill.ForeColor.RGB = .Font.Color 'add Font color
        End With
    Next i


    tbox1.Fill.ForeColor.RGB = cell.Interior.Color 'add background color
    End With
End Sub

来源：https://stackoverflow.com/questions/60827598/copy-from-cell-to-textbox-and-maintain-all-formatting-with-vba

标签

excel