Как сохранить стиль шрифта курсивом из строки?

Question

У меня есть код, который соединяет некоторые строки.

Например:

До

Сейчас

Я хочу видеть

Проблема в том, чтов неотредактированной строке есть курсивные слова, но когда я пытаюсь присоединиться к этой строке, курсивные слова становятся без этого шрифта, как мне отредактировать мой код?

Sub MergeText()

    Dim strMerged$, r&, j&, i&, uneditedColumn As Long, resultColumn As Long
    With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
    uneditedColumn = 1 ' Column number which need to edit !!! uneditedColumn must not be equal resultColumn
    resultColumn = 3 ' Column number where need to put edited text
    r = 1
    Do While True
        If Cells(r, uneditedColumn).Characters(1, uneditedColumn).Font.Bold Then
            strMerged = "": strMerged = Cells(r, uneditedColumn)
            r = r + 1
            While (Not Cells(r, uneditedColumn).Characters(1).Font.Bold) And Len(Cells(r, uneditedColumn)) > 0
                strMerged = strMerged & " " & Cells(r, uneditedColumn)
                r = r + 1
            Wend
            i = i + 1: Cells(i, resultColumn) = strMerged
            Cells(i, resultColumn).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
        Else
            Exit Do
        End If
    Loop
End With
End Sub

Answer 1

Я сделал это так:

• Объединяет строки, используя правило, согласно которому каждая строка result начинается, когда форматируется первый символ строки неотредактированный BOLD .
• Поскольку мы обрабатываем каждую неотредактированную строку , сохраняем каждое свойство шрифтов Bold и Italic символов в словаре, используя объект коллекции. Ключом словаря является номер строки в диапазоне result ; элемент коллекции состоит из массива, описывающего свойства character.font для Bold и Italic.
• Природа вещей такова, что номер элемента коллекции будет соответствовать позиции символа в строке result .

---

Option Explicit
Sub copyWithFormat()
    Dim WS As Worksheet
    Dim rUnedited As Range, rResult As Range, C As Range
    Dim S As String
    Dim I As Long, J As Long, K As Long
    Dim Dict As Object, Col As Collection

Set WS = Worksheets("sheet2")
With WS
    Set rUnedited = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    Set rResult = .Cells(1, 3)
End With

rResult.EntireColumn.Clear

Set Dict = CreateObject("Scripting.Dictionary")

I = 0  'rResult rows
For Each C In rUnedited
    Select Case C.Characters(1, 1).Font.Bold
        Case True 'start of a string
            I = I + 1
            rResult(I, 1) = C
            Set Col = New Collection
                For J = 1 To Len(C)
                    Col.Add Array(C.Characters(J, 1).Font.Bold, C.Characters(J, 1).Font.Italic)
                Next J
                Dict.Add Key:=I, Item:=Col
        Case False
            rResult(I, 1) = rResult(I, 1) & " " & C
            Dict(I).Add Array(False, False) 'for the intervening space
            For J = 1 To Len(C)
                Dict(I).Add Array(C.Characters(J, 1).Font.Bold, C.Characters(J, 1).Font.Italic)
            Next J
    End Select
Next C

'Format the characters
Set rResult = Range(rResult(1, 1), rResult.End(xlDown))

I = 0
For Each C In rResult
    I = I + 1
    For J = 1 To Dict(I).Count
        C.Characters(J, 1).Font.Bold = Dict(I)(J)(0)
        C.Characters(J, 1).Font.Italic = Dict(I)(J)(1)
    Next J
Next C
End Sub

неотредактировано (заметьте, я добавил немного жирного и курсивного форматирования из того, что у вас изначально было)

Результат