提取格式的字符串的一部分（粗体和颜色和下划线）

Question

我有＆＃34; mytable＆＃34;的单元格（x，y） mytable是sheet（1）的列表对象

用户编辑了单元格1,1并添加了格式为单元格1,1的结果内容： 重要说明：我无法在此处重现颜色，但假设某些编辑还包括颜色，不仅粗体和草书

Lorem ipsum dolor 坐下来，奉献精神。 Etiam ultricies，leo quis euismod condimentum，Sed clamp | general term turpis nibh ullamcorper erat，nec finibus ipsum nunc ut urna 。 Proin a tortor ullamcorper，congue turpis eget， gravida lectus 。 Pellentesque居民morbi

现在我需要用＃34;＆lt;＆lt;＆＃;＆＃34;符号来分割单元格内容。但要保持新细胞的形成

Lorem ipsum dolor sit amet ，consectetur＆lt; term turpis nibh ullamcorper erat，nec finibus ipsum nunc ut urna 。 ＆lt; gravida lectus。 Pellentesque居民morbi

我知道如何使用listobject进行操作 我可以将单元格的范围放在变量

中

dim myRange as range
'first data of first column of first table that is also the only one in the sheet
set mysheet=thisworkbook.sheets("whateversheet")
set myrange= mySheet.listobjects(1).listcolumns(1).databodyrange(1)
set OtherRange=range("a3")
mySht.OtherRange.PasteSpecial Paste:=xlPasteAllExceptBorders

使用此代码，我可以将单元格1,1的全部内容粘贴到a3字体和颜色中。 但是只要我想获得内容（值）以及该单元格的PART的字体和颜色，我就不知道如何使用listobject（或任何其他方法）。

当然以下代码不保留格式：

dim myStr as string
myStr=mid(myrange.value,1,instr(1,myrange,"<<"))

所以问题是：是否有任何＆＃34;简单有效的＆＃34;这样做的方法？ 结果将用于将单元格1,1的内容分成与simbols一样多的单元格＆lt;＆lt;＆lt;＆＃;在单元格1,1中，将格式（颜色和字体粗体和所有内容）粘贴到其他单元格中。

非常感谢

Answer 1

这可能有所帮助 - 我不知道更短的方式。如果将A1中的格式化文本复制到B1，则说明如何捕获单个字符的格式。

Sub x()

Dim i As Long

Range("B1").Value = Range("A1").Value

For i = 1 To Len(Range("B1"))
    Range("B1").Characters(i, 1).Font.Bold = Range("A1").Characters(i, 1).Font.Bold
    Range("B1").Characters(i, 1).Font.Color = Range("A1").Characters(i, 1).Font.Color
Next i

End Sub

Answer 2

谢谢SJR这里的代码 a）将单元格X的字符串分成不同的部分 b）复制包括原始布局的不同部分，关闭单元格X中的每个字符

Private Sub copy_font()
'purpose of this sub:
'divide a string of a cell into parts and paste the parts into other cells
'KEEPING THE FONT AND COLOR OF THE ORIGINAL CELL
'WHEREIN IN THE ORIGINAL CELL ALL KIND OF MIX FONTS AND COLORS OCCUR

Dim MySht As Worksheet
Set MySht = ThisWorkbook.Sheets("font")
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim myString As String
Dim StartCharacter As Integer
Dim EndCharacter As Integer
Dim numberofSimbols As Integer
Dim myStr As String

'any string value in a particular cell
myString = MySht.Cells(1, 1).Value
'imagine I want to divide the text everytime a simbol "<<" appears
numberofSimbols = (Len(myString) - Len(Replace(myString, "<<", ""))) / 2

StartCharacter = 1
EndCharacter = InStr(StartCharacter, myString, "<<")

For j = 1 To numberofSimbols + 1
    'copy the value string into another cell (I chose here the cells in the row where myString is
    MySht.Cells(1, j + 1).Value = Mid(myString, StartCharacter, EndCharacter - StartCharacter)

    Debug.Print j, StartCharacter, EndCharacter, Mid(myString, StartCharacter, EndCharacter - 1)
    'loop to pass the font/color/underline...etc
    k = 0
    For i = StartCharacter To EndCharacter - 1
        k = k + 1
        MySht.Cells(1, j + 1).Characters(k, 1).Font.Bold = Range("a1").Characters(i, 1).Font.Bold
        MySht.Cells(1, j + 1).Characters(k, 1).Font.Color = Range("a1").Characters(i, 1).Font.Color
        MySht.Cells(1, j + 1).Characters(k, 1).Font.Bold = Range("a1").Characters(i, 1).Font.Bold
        MySht.Cells(1, j + 1).Characters(k, 1).Font.Italic = Range("a1").Characters(i, 1).Font.Italic
        MySht.Cells(1, j + 1).Characters(k, 1).Font.Underline = Range("a1").Characters(i, 1).Font.Underline
    Next i

'now for the next loop advance in myString
StartCharacter = EndCharacter + 2 '2 because "<<" is two characters long.
EndCharacter = InStr(StartCharacter, myString, "<<")
'MsgBox "next" & Chr(10) & StartCharacter & Chr(10) & EndCharacter
If EndCharacter = 0 Then
    'The last loop hast to be done till the end of myString. but instr will evaluate Zero result in the last loop
    'therefore in last loop:
    EndCharacter = Len(myString)
End If

Next j
End Sub

请注意，使用长文章运行此代码可能需要很长时间才能完成此操作 （I.E.SWVERAL LONG SECONDS）