Скопируйте из ячейки в текстовое поле и сохраните все форматирование с помощью VBA

Question

Мне нужно иметь возможность скопировать все данные, введенные в ячейку, и скопировать их в текстовое поле. Текст представляет собой смесь различных стилей шрифтов, включая цвета, полужирный шрифт, itali c и подчеркнутый текст.

После этого пользователь сможет вводить больше информации в текстовое поле, используя различные стили и т. Д. c.

Надежда оттуда - возможность использовать vba для копирования обратно в исходная ячейка из текстового поля.

Обоснование состоит в том, чтобы позволить пользователю иметь возможность вводить довольно длинные заметки без ограничений ячейки. Я открыт для размышлений о вложенном объекте (слове). Но я не мог понять, как это сделать.

Я нашел этот код, который помог опубликовать Дэвид, но он не включает, например, код, относящийся к цвету шрифта. Когда я пытаюсь добавить его, он выдает и выдает ошибку.

Вот код, который я нашел:

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

Если кто-то может помочь, я был бы очень признателен .

Answer 1

Возможно, это то, что вам нужно:

• Чтобы это работало, убедитесь, что вы выбрали правильный activeCell, и "textbox 1" существует
• Вот некоторые другие варианты: TextboxUnderline
• Вызовите CopyCelltoTextbox для запуска макроса!

.

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