Split cell value and keep formatting on new workbook

Question

I am attempting to select a cell filled with text and split/parse the text onto individual rows in a new workbook while maintaining the source font format (i.e. bold text).

In the code below I am attempting to perform my split on the row cell value, which I know will remove my formatting and bold font. This works if my bold text is in a cell by itself, but when I have bold and non-bold text in the same cell, my entire output ends up bolded. If I omit the bold font change, then my cell is missing the bold font.

Is there a way to perform a split while maintaining the cell format?

Sub Macro1()

    Dim InputData As Range
    Dim arr() As String
    Dim NewBook As Workbook
    Dim shnew As Worksheet

    counter = 0
    counter2 = 0
    Boxtitle = " Find and Bold"""

    Set InputData = Application.Selection.Range("A1")
    Set InputData = Application.InputBox("Select cell Range: ", Boxtitle, InputData.Address, Type:=8)

    'Create new workbook instance
    Set NewBook = Workbooks.Add
    Set shnew = NewBook.Worksheets.Add

    ' Loop through range and split on delimitter and add to array
    For Each x In InputData.Rows
        If InputData.Cells(1 + counter, 1).Font.Bold = False Then
            arr = Split(InputData.Cells(1 + counter, 1), ". ")
            counter = counter + 1
            For Each i In arr
                shnew.Cells(1 + counter2, 1) = i
                counter2 = counter2 + 1
            Next
        Else
            arr = Split(InputData.Cells(1 + counter, 1), ". ")
            counter = counter + 1
            For Each i In arr
                shnew.Cells(1 + counter2, 1).Font.Bold = True
                shnew.Cells(1 + counter2, 1) = i
                counter2 = counter2 + 1
            Next
        End If
    Next

End Sub

Not knowing what your requirement and source of your data is: but maybe it's worth to do this in Word. There you would also have a `Sentence`-object ... — Ike, Oct 11 '22 at 07:29

JvdV · Answer 1 · 2022-10-11T07:31:51.810

This will prove not to be that easy. AFAIK your best bet is to loop over each and every character. One way would be:

Sub Test()

Dim s As Range: Set s = Range("A1")
Dim c As Range: Set c = Range("B1")
Dim r As Variant, x As Long, y As Long

With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = ".*?(?:\. |$)"
    If .Test(s.Value) Then
        Set r = .Execute(s)
        For Each Match In r
            c.Value = Match
            y = Match.FirstIndex
            For x = 1 To Len(Match)
                c.Characters(x, 1).Font.Bold = s.Characters(y + x, 1).Font.Bold = True
                c.Characters(x, 1).Font.Italic = s.Characters(y + x, 1).Font.Italic = True
                c.Characters(x, 1).Font.Strikethrough = s.Characters(y + x, 1).Font.Strikethrough = True
                c.Characters(x, 1).Font.Name = s.Characters(y + x, 1).Font.Name
                c.Characters(x, 1).Font.Color = s.Characters(y + x, 1).Font.Color
                c.Characters(x, 1).Font.Size = s.Characters(y + x, 1).Font.Size
                c.Characters(x, 1).Font.Underline = s.Characters(y + x, 1).Font.Underline
            Next
            Set c = c.Offset(1, 0)
        Next
    End If
End With

End Sub

As you noticed I added more font characteristics than just bold. Erase/add accordingly. Obviously I had range variables for testing. Apply appropriate ones to suit your case. Some test results:

Hi Jvdv, Thank you! This looks good but I am not sure how to incorporate a user defined range with your code and have the result populate on a new workbook. Do you have any guidance regarding this? — AnotherDay, Oct 11 '22 at 19:07

Split cell value and keep formatting on new workbook

1 Answers1