从文本框复制到单元格，并使用vba维护所有格式

Question

大家下午好。我现在需要能够将格式化的文本框发送回原始活动单元格。

这个代码是从单元格复制到文本框的格式，我现在需要反转这个过程

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

非常感谢您抽出时间阅读，请大家身体健康。

Answer 1

关注您的问题：

• 首先，确保"textbox 2" exists
• 然后，选择需要复制格式的单元格并运行代码CopyFormat_fromTextbox_toCell

以下代码：

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