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

Question

我需要能够复制在单元格中输入的所有数据并将其复制到文本框。文本混合了不同的字体样式，包括颜色、粗体、斜体和带下划线的文本。

然后，用户将能够使用不同的样式等在文本框中输入更多信息。

从那里希望能够使用 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

结束子

如果有人可以提供帮助，我将不胜感激。

标签： excel

Answer 1

也许这就是你需要的：

• 要使其正常工作，请确保选择正确的 activeCell 并且存在“文本框 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