Скопируйте из текстового поля в ячейку и сохраните все форматирование с помощью 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