Извлечь часть строки из ячейки формата WITH (жирным шрифтом, цветом и подчеркиванием)

Question

Я имею в ячейке (x,y) "mytable" mytable - это список объектов листа (1)

Пользователь отредактировал ячейку 1,1 и добавил формат с содержимым результата ячейки 1,1: Важное примечание: я не могу воспроизвести здесь цвет, но предполагаю, что часть редактирования включает в себя цвета, а не только полужирный и курсивный

Lorem Ipsum Dolor Sit Amet, Concetetur Adipiscing Elit. Etiam ultricies, leo quis euismod condimentum, Sed зажим | общий термин turpis nibh ullamcorper erat, nec finibus ipsum nunc ut urna. Proin a tortor ullamcorper, congue turpis eget, gravida lectus. Пелентеский житель морби

Теперь мне нужно разделить содержимое ячейки на символ "<<", но сохраняя форматирование в новых ячейках

Lorem ipsum dolor sit amet, consctetur ipsum nunc ut urna. <гравида лектус. Пелентеский житель морби

Я знаю, как работать с 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 и цвета. но как только я хочу получить содержимое (значение), шрифт и цвет только ЧАСТИ этой ячейки, я не знаю, как использовать listobject (или любой другой метод).

конечно, следующий код не сохраняет форматирование:

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

Таким образом, вопрос заключается в следующем: есть ли "легкий-эффективный" способ сделать это? Результат будет использоваться для разбиения содержимого ячейки 1,1 на столько ячеек, сколько символов "<<" в ячейке 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 здесь код, который а) делит строку ячейки X на разные части; б) копирует разные части, ВКЛЮЧАЯ ОРИГИНАЛЬНЫЙ ПЛАН, с каждого символа в ячейке 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

БУДЬТЕ ВНИМАТЕЛЬНЫ, ИСПОЛЬЗУЯ ЭТОТ КОДЕКС НА МНОЖЕСТВЕ КЛЕТОК С ДЛИННЫМИ ТЕКСТАМИ, ВОЗМОЖНО ПРИНЯТЬ ВОЗРАСТ (т.е. НЕСКОЛЬКО ДЛИННЫХ СЕКУНД)