Excel macro to insert newline before specific text.

[feudal]

Hi, I need some help to format a spreadsheet. I need a macro that will bold specific text and insert a newline before said text. The bold works, but I don't know the best way to insert the linebreak. I tired with cell.Replace but that's acting weird. Maybe someone has a better solution.

Sub Find_and_Bold()
Dim rCell As Range, sToFind As String, iSeek As Long
Dim Text(1 To 4) As String
Dim i As Integer

Text(1) = "[CUSTOMIZED APPROACH OBJECTIVE]:"
Text(2) = "[APPLICABILITY NOTES]:"

For Each rCell In Range("D1:D100")
'rCell.Replace What:="[", Replacement:=vbLf & "["
    For i = LBound(Text) To UBound(Text)
            sToFind = Text(i)
           iSeek = InStr(1, rCell.Value, sToFind)
        Do While iSeek > 0
            rCell.Characters(iSeek, Len(sToFind)).Font.Bold = True
            iSeek = InStr(iSeek + 1, rCell.Value, sToFind)
        Loop
    Next i
Next rCell

End Sub

When I uncomment line 10 it kinda works but acts oddly when I test multiple cells. I'm sure there is a better way to accomplish this but I don't know what that would be.

The excel sheet looks like this before formatting.

I would like it to look like this after I run the macro.

Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. [CUSTOMIZED APPROACH OBJECTIVE]: Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.[APPLICABILITY NOTES]: Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.

Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. [CUSTOMIZED APPROACH OBJECTIVE]: Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. [APPLICABILITY NOTES]: Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.

Also, some cells are empty, some cells have both [TITLES] and still others have one or the other.

Thanks for your help!

 

[rlv01]

One way.

Sub Find_and_Bold()
    Dim rCell As Range, sToFind As String, iSeek As Long
    Dim Text(1 To 2) As String
    Dim i As Integer
    Dim S As String
    Dim SPos As Long
    
    Range("E4").Copy Range("D4")
    
    Text(1) = "[CUSTOMIZED APPROACH OBJECTIVE]:"
    Text(2) = "[APPLICABILITY NOTES]:"
    
    'Add LF
    For Each rCell In Range("D1:D100")
        SPos = 1
        For i = LBound(Text) To UBound(Text)
            sToFind = Text(i)
            iSeek = InStr(SPos, rCell.Value, sToFind)
            If iSeek > SPos Then
                With rCell
                    .Value = Left(.Value, iSeek - 1) & Chr(10) & Chr(10) & Mid(.Value, iSeek, Len(.Value))
                    SPos = iSeek + 1
                End With
            End If
        Next i
    
    'Add bolding
        SPos = 1
        For i = LBound(Text) To UBound(Text)
            sToFind = Text(i)
            iSeek = InStr(SPos, rCell.Value, sToFind)
            If iSeek > SPos Then
                With rCell
                    rCell.Characters(iSeek, Len(sToFind)).Font.Bold = True
                    SPos = iSeek + 1
                End With
            End If
        Next i
    Next rCell
End Sub

 

[igold]

An alternative approach... Original text in Column D - Output to Column E

Sub Find_and_Bold()

    Dim spl, text
    Dim x As Long, s As Long, i As Long, p1 As Long
    Dim nText As String, rCell As String
  
    text = Array("[CUSTOMIZED APPROACH OBJECTIVE]:", "[APPLICABILITY NOTES]:")
  
    For x = 1 To 100
        rCell = Range("D" & x).text
        spl = Split(rCell, "[")
        If UBound(spl) > 0 Then
            For s = LBound(text) To UBound(text)
                For i = LBound(spl) To UBound(spl)
                    If InStr(spl(i), Mid(text(s), 2)) > 0 Then
                        spl(i) = "[" & spl(i)
                        spl(i) = CStr(spl(i))
                    End If
                Next
            Next
        End If
        If Not Range("D" & x) = "" Then
            For i = LBound(spl) To UBound(spl)
                nText = nText & spl(i) & vbNewLine & vbNewLine
            Next
        End If
            Range("E" & x).Font.Bold = False
            Range("E" & x) = nText
            For s = LBound(text) To UBound(text)
                p1 = InStr(Range("E" & x), text(s))
                If p1 <> 0 Then
                    With Range("E" & x).Characters(Start:=p1, Length:=Len(text(s))).Font
                        .FontStyle = "bold"
                    End With
                    p1 = 0
                End If
            Next
            nText = ""
    Next

End Sub

 

[rlv01]

One more thing about the code I posted above. This line:

    Range("E4").Copy Range("D4")

should be deleted. It is some leftover test code I was using to refresh the data cell between runs that I forgot to take out. So without it, it would be:

Sub Find_and_Bold()
    Dim rCell As Range, sToFind As String, iSeek As Long
    Dim Text(1 To 2) As String
    Dim i As Integer
    Dim S As String
    Dim SPos As Long
    
    Text(1) = "[CUSTOMIZED APPROACH OBJECTIVE]:"
    Text(2) = "[APPLICABILITY NOTES]:"
    
    'Add LF
    For Each rCell In Range("D1:D100")
        SPos = 1
        For i = LBound(Text) To UBound(Text)
            sToFind = Text(i)
            iSeek = InStr(SPos, rCell.Value, sToFind)
            If iSeek > SPos Then
                With rCell
                    .Value = Left(.Value, iSeek - 1) & Chr(10) & Chr(10) & Mid(.Value, iSeek, Len(.Value))
                    SPos = iSeek + 1
                End With
            End If
        Next i
    
    'Add bolding
        SPos = 1
        For i = LBound(Text) To UBound(Text)
            sToFind = Text(i)
            iSeek = InStr(SPos, rCell.Value, sToFind)
            If iSeek > SPos Then
                With rCell
                    rCell.Characters(iSeek, Len(sToFind)).Font.Bold = True
                    SPos = iSeek + 1
                End With
            End If
        Next i
    Next rCell
End Sub