How to save font style italic from string?

Question

I have code which joins some strings.

For example:

Before

Now

I want to see

The problem is that the unedited string has italic words, but when I try to join this string, italic words become without this font, how I should edit my code?

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

I've done it this way:

• Concatenate the strings using the rule that each result row starts when the first character of an unedited row is formatted BOLD.
• As we process each unedited row, store each characters font Bold and Italic property in a dictionary using a collection object. The dictionary key is the row number in the result range; the collection item consists of an array describing the character.font properties of Bold and Italic.
• The nature of things is that the collection item number will correspond to the character position in the result string.

---

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

Unedited (note I added some bold and italic formatting from what you originally had)

Result