Detect bold texts in a cell and add ";" before those texts

Question

I have 3 columns that have the same pattern. Here is the example:

" I Love Chocolate
I really love chocolate
I want to drink hot chocolate
I have a red bike
I buy it with my own money
I hate mouse
I hate mouse since I was little "

I want to add semicolon before each of the line of bold texts in the cell. Like this:

" ;I Love Chocolate
I really love chocolate
I want to drink hot chocolate
;I have a red bike
I buy it with my own money
;I hate mouse
I hate mouse since I was little "

I used a Macro like this, but it doesn't work. It gave no error warning; it just doesn't work as I wanted it to be.

Sub AddSemicolonBeforeBoldText()
    Dim rng As Range
    Dim cell As Range
    Dim text As String
    Dim startPos As Integer
    Dim endPos As Integer
    
    Set rng = ActiveSheet.UsedRange
    
    For Each cell In rng
        If cell.HasFormula Then
            ' Skip cells with formulas
            GoTo ContinueLoop
        End If
        
        text = cell.Value
        startPos = 1
        
        Do While startPos <= Len(text)
            startPos = InStr(startPos, text, "*", vbTextCompare)
            If startPos = 0 Then Exit Do
            
            endPos = InStr(startPos + 1, text, "*", vbTextCompare)
            If endPos = 0 Then Exit Do
            
            ' Insert a semicolon before the bold text
            text = Left(text, startPos - 1) & ";" & Mid(text, startPos)
            startPos = endPos + 1 ' Move the start position after the second asterisk
        Loop
        
        cell.Value = text
        
        ContinueLoop:
    Next cell
End Sub

What did I do wrong?

Answer 1

Prepend String to Bold Cell Row

Sub PrependStringToBoldCellRow()
    
    Const INSERT_STRING As String = ";"
    Const PREVENT_CONSECUTIVE_INSERTIONS As Boolean = True
    Const MATCH_INSERT_STRING_CASE As Boolean = False
    Const CELL_ROW_DELIMITER As String = vbLf ' or vbCrLf?
    
    If ActiveSheet Is Nothing Then Exit Sub
    If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim rng As Range: Set rng = ws.UsedRange
    
    Dim iLen As Long: iLen = Len(INSERT_STRING)
    Dim iCompare As VbCompareMethod:
    
    If MATCH_INSERT_STRING_CASE Then
        iCompare = vbBinaryCompare
    Else
        iCompare = vbTextCompare
    End If
    
    Application.ScreenUpdating = False
    
    Dim cell As Range, chars As Characters
    Dim sRows() As String, sStarts() As Long, sLens() As Long
    Dim u As Long, UB As Long, sStart As Long, sLen As Long
    Dim CellString As String, RowString As String
    Dim IsCellStringValid As Boolean, IsConsecutive As Boolean
    
    For Each cell In rng.Cells
        
        ' Validate
        If Not cell.HasFormula Then ' has no formula
            If VarType(cell.Value) = vbString Then
                CellString = CStr(cell.Value)
                If Len(CellString) > 0 Then
                    IsCellStringValid = True
                Else
                    Debug.Print "Cell """ & cell.Address(0, 0) & """ is blank."
                End If
            Else
                Debug.Print "Cell """ & cell.Address(0, 0) & """ has no string."
            End If
        Else
            Debug.Print "Cell """ & cell.Address(0, 0) & """ has a formula."
        End If
        
        If IsCellStringValid Then
            IsCellStringValid = False ' reset for the next cell
            Debug.Print "Processing cell """ & cell.Address(0, 0) & """."
            
            sRows = Split(CellString, CELL_ROW_DELIMITER)
            UB = UBound(sRows)
            ReDim sStarts(0 To UB): ReDim sLens(0 To UB)
            sStart = 1
            
            For u = 0 To UB
                sLen = Len(sRows(u))
                sStarts(u) = sStart
                sLens(u) = sLen
                sStart = sStart + sLen + 1
            Next u
            
            For u = UB To 0 Step -1
                Set chars = cell.Characters(sStarts(u), sLens(u))
                RowString = chars.Text
                
                If PREVENT_CONSECUTIVE_INSERTIONS Then
                    If InStr(1, RowString, INSERT_STRING, iCompare) _
                            = 1 Then ' begins with
                        IsConsecutive = True
                    End If
                End If
                
                If IsConsecutive Then
                    IsConsecutive = False ' reset for the next row string
                    Debug.Print vbTab & RowString & " (is bold; " _
                        & "prevented consecutive insertion)"
                Else
                    If chars.Font.Bold Then
                        Debug.Print vbTab & RowString & " (is bold; " _
                            & "inserting...)"
                        chars.Insert INSERT_STRING & RowString
                    Else
                        Debug.Print vbTab & RowString & " (is not bold)"
                    End If
                End If
            Next u
        End If
    
    Next cell
    
    Application.ScreenUpdating = True
    
    MsgBox "Semicolons prepended.", vbInformation
    
End Sub

Log

Processing cell "A1".
    I hated mice since I was little (is bold; inserting...)
    I hate mice (is not bold)
    I bought it with my own money (is not bold)
    I have a red bike (is bold; inserting...)
    I want to drink hot chocolate (is not bold)
    I really love chocolate (is not bold)
    I Love Chocolate (is bold; inserting...)
Cell "A2" has a formula.
Cell "A3" has no string.
Cell "A4" has no string.
Processing cell "A5".
    AAA (is not bold)
Processing cell "A6".
    AAA (is bold; inserting...)
Cell "A7" has no string.
Cell "A8" has no string.
Cell "A9" has no string.
Cell "A10" has no string.

Answer 2

Try this, it steps backwards through each character in the cell, if the character is not bold and the character following it is bold then it adds a semicolon (the semicolon itself being bold)

Sub AddSemicolonBeforeBoldText()
    Dim rng As Range
    Dim cell As Range
    
    Set rng = ActiveSheet.UsedRange
    
    For Each cell In rng
        If cell.HasFormula Then
            ' Skip cells with formulas
            GoTo ContinueLoop
        End If
        
        Dim i As Long
        For i = cell.Characters.Count - 2 To 0 Step -1
            If i = 0 Or Not cell.Characters(i, 1).Font.Bold Then
                If cell.Characters(i + 1, 1).Font.Bold Then
                    cell.Characters(i + 1, 0).Insert ";"
                End If
            End If
        Next i
        
ContinueLoop:
    Next cell
End Sub

... if you want, you can also tidy the code up further by eliminating the GoTo as follows

Sub AddSemicolonBeforeBoldText()
    Dim rng As Range
    Dim cell As Range
    
    Set rng = ActiveSheet.UsedRange
    
    For Each cell In rng
        If Not cell.HasFormula Then
            Dim i As Long
            For i = cell.Characters.Count - 2 To 0 Step -1
                If i = 0 Or Not cell.Characters(i, 1).Font.Bold Then
                    If cell.Characters(i + 1, 1).Font.Bold Then
                        cell.Characters(i + 1, 0).Insert ";"
                    End If
                End If
            Next i
        End If
    Next cell
End Sub

Answer updated with images

The code will change this ...

... to this ...

Answer 3

Sub AddSemicolonToBoldText()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim i As Integer
    Dim text As String
    
    ' Set the worksheet to work with
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with your sheet name
    
    ' Set the range to loop through (Columns A, B, and C from A1 to C2000)
    Set rng = ws.Range("A1:C2000")
    
    For Each cell In rng
        If Not IsEmpty(cell.Value) And cell.Font.Bold Then ' Check if the cell value is bold and not blank
            ' Split the cell value by spaces to handle multiple bold words within the same cell
            Dim words() As String
            words = Split(cell.Value, " ")
            
            ' Add a semicolon before each bold word
            For i = LBound(words) To UBound(words)
                If cell.Characters(Start:=InStr(cell.Value, words(i)), Length:=Len(words(i))).Font.Bold Then
                    words(i) = ";" & words(i)
                End If
            Next i
            
            ' Join the modified words back into the cell
            cell.Value = Join(words, " ")
        End If
    Next cell
End Sub