Copy from textbox to cell and maintain all formatting with vba - excel

Question

Good afternoon to all.
I now need be able to send the formatted textbox back to the originating active cell.
This code was copy format from cell to textbox, I now need to reverse this process
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
Many thanks for taking the time to read, and please everyone, stay well.

Answer 1

focus on your problem:
First, make sure "textbox 2" exists
Then, Select the cell need to copy format and run the code CopyFormat_fromTextbox_toCell
Here's following code:
Sub CopyFormat_fromTextbox_toCell()
CopycellFormat1 activecell
End Sub
Private Sub CopycellFormat1(cell As Range)
Dim textrange As TextRange2, tbox1 As Shape, fontType As Font2, cellfont As Font
With ActiveSheet
Set tbox1 = .Shapes("Textbox 2"): Set textrange = tbox1.TextFrame2.textrange
cell.Value = textrange.Characters.Text
For i = 1 To Len(cell.Value)
Set fontType = textrange.Characters(i, 1).Font
Set cellfont = cell.Characters(i, 1).Font
With fontType
cellfont.Bold = IIf(.Bold, True, 0) 'add bold/
cellfont.Italic = IIf(.Italic, True, 0) 'add italic/
cellfont.Underline = IIf(.UnderlineStyle > 0, 2, -4142) 'add underline/
cellfont.Color = textrange.Characters(i, 1).Font.Fill.ForeColor.RGB 'add Font color
End With
Next i
cell.Interior.Color = tbox1.Fill.ForeColor.RGB 'add background color
End With
End Sub