extract part of a string of a cell WITH format (bold and color and underline)

Question

I have in cell(x,y) of "mytable" mytable is a listobject of sheet(1)

The user edited the cell 1,1 and added format with the result content of cell 1,1: Important note: I can not reproduce here color, but assume some of the editing includes colors as well, not only bold and cursive

Lorem ipsum dolor sit amet, consectetur adipiscing elit. 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 habitant morbi

Now I need to split the cell content by the symbol "<<" but keeping formating in the new cells

Lorem ipsum dolor sit amet, consectetur <term turpis nibh ullamcorper erat, nec finibus ipsum nunc ut urna. <gravida lectus. Pellentesque habitant morbi

I know how to operate with listobject I can put the range of the cell in a variable

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

With this code I can paste the whole content of cell 1,1, into a3 font and colors included. but as soon as I want to get the content (value) and the font and color of just PART of that cell I dont know how to use listobject (or any other method).

of course the following code do not preserve formatting:

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

So the question is: Is there any "easy-effective" way to do this? The result would be used to split the content of the cell 1,1 into as many cells as simbols "<<" in cell 1,1 and paste the values with format (color and font bold and everything) into other cells.

thanks a lot

Answer 1

Thanks SJR here the code that a) divide the string of a cell X into different parts b) copy the different parts INCLUDING THE ORIGINAL LAYOUT off every character in cell 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

BE AWARE, RUNNING THIS CODE OVER A LOT OF CELLS WITH LONG TEXTS MIGHT TAKE AGES (I.E. SEVERAL LONG SECONDS)

Answer 2

This might help - I don't know of a shorter way. If formatted text in A1 is copied to B1 this is an illustration of how to capture the formatting of individual characters.

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