Извлечь часть строки из ячейки формата WITH (жирным шрифтом, цветом и подчеркиванием)
Я имею в ячейке (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
Я знаю, как работать с 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 и вставки значений с форматом (цвет и шрифт полужирный и все) в другие ячейки.
большое спасибо
2 ответа
Это может помочь - я не знаю более короткого пути. Если форматированный текст в 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
Благодаря 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
БУДЬТЕ ВНИМАТЕЛЬНЫ, ИСПОЛЬЗУЯ ЭТОТ КОДЕКС НА МНОЖЕСТВЕ КЛЕТОК С ДЛИННЫМИ ТЕКСТАМИ, ВОЗМОЖНО ПРИНЯТЬ ВОЗРАСТ (т.е. НЕСКОЛЬКО ДЛИННЫХ СЕКУНД)