Going through every instance of a string in text boxes

Code:

---

Sub Beta2()
  Dim oshp As Shape, osld As Slide, TxtChng As String, i As Integer
 
 
      For Each osld In ActivePresentation.Slides
      For Each oshp In osld.Shapes
        If oshp.HasTextFrame Then
            If oshp.TextFrame.HasText Then
                TxtChng = InStr(oshp.TextFrame.TextRange.Characters.Text, ChrW(&H3B2) & "2")
               
                If TxtChng > 0 Then
                    For i = 1 To 3
                        With oshp.TextFrame.TextRange.Characters(foundAt + 1)
                            .Font.Subscript = True
                        End With
                  Next i
                End If
            End If
        End If
      Next oshp
  Next osld


End Sub

---

Before I expand this code to have the option to have a user defined search term (rather than being fixed to β2, as it is now), I've realised that something is still not quite right with this. I think I know, broadly, what is going wrong, but I don't know how to set it right.

The code as it currently stands will only change β2 to β₂ for the first instance in each text box. If there is more than one β2 in the text box, it will only do the first one. I tried adding the i loop, thinking this would make it run through the whole text box, but I realise now that this was stupid, and that it's just applying the change to the first β2 three times!

Is there a way to get this to change ALL of the β2 in each text box to β₂?

My grand plan is to expand this code to be a functioning search and replace for text that needs superscripts and subscripts (hence my previous question about versatile inputboxes), but I want to get this bit right before trying out anything more extensive.

Thanks for your help!

This is how to do that the original code is by my friend Shyam and there is a more complex version on his site.

Code:

---

Sub GlobalFindAndReplace()' original code by Shyam Pillai
' more complex version
' http://skp.mvps.org/ppt00025.htm#2
Dim oPres As Presentation
Dim oSld As Slide
Dim oShp As Shape
Dim FindWhat As String
Dim ReplaceWith As String


FindWhat = "ß2"
ReplaceWith = "ß" & ChrW(8322)
For Each oPres In Application.Presentations
    For Each oSld In oPres.Slides
        For Each oShp In oSld.Shapes
            Call ReplaceText(oShp, FindWhat, ReplaceWith)
        Next oShp
    Next oSld
Next oPres
End Sub


Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim I As Integer




    If oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oTxtRng = oShp.TextFrame.TextRange
            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                Replacewhat:=ReplaceString, WholeWords:=True)
            Do While Not oTmpRng Is Nothing
                Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
                            Replacewhat:=ReplaceString, _
                            After:=oTmpRng.Start + oTmpRng.Length, _
                            WholeWords:=True)
            Loop
      End If
    End If


End Sub

---

John, you really are a legend. Many thanks to you, and of course to your friend Shyam. Can't tell you how appreciative I am!

So, I've done a bit more messing around, and have now bodged together a macro that will let me input any string, including a workaround for a certain number of Greek letters that I commonly need to use (I haven't tried a userform yet. I know this would be considerably more elegant, but I've never tried using one so I'm a bit afraid!). I imagine my code is extraordinarily messy, but it is more or less doing what I want it to.

However, it is not applying the selected changes to tables or SmartArt objects. Is there anyway around this? Here's my current Frankenstein code:

Code:

---

Sub A_Sub_Sup()
    Dim sld As Slide
    Dim shp As Shape
    Dim txtRng As TextRange, rngFound As TextRange
    Dim i As Long, n As Long, c As Long, d As Long
    Dim sTxt2Chng As String, sFndStrng As String, sScript As String, strMsg As String, strMsg2 As String, strMsg3 As String, strMsg4 As String
   
    strMsg = "Make selected character superscript or subscript?" & vbNewLine & vbNewLine
    strMsg = strMsg & "Type" & vbTab & "Super" & vbTab & "for SUPERSCRIPT" & vbNewLine
    strMsg = strMsg & "Type" & vbTab & "Sub" & vbTab & "for SUBSCRIPT"
   
    strMsg2 = "Enter text example" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "Only needs to be a partial text string" & vbNewLine
    strMsg2 = strMsg2 & "For example, if you want to superscript the 3 in cells/mm3, just enter:" & vbTab & "mm3" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "To superscript a character AFTER alpha/beta/gamma/delta or DELTA" & vbNewLine
    strMsg2 = strMsg2 & "type <GR>a/b/g/d/u-d followed by the character to change" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "For example, if you want to indicate the beta symbol, enter:" & vbTab & "<GR>b"


    strMsg3 = "What position in your text string is the character?" & vbNewLine & vbNewLine
    strMsg3 = strMsg3 & "For example, the 2 in H20 is position 2, and the 3 in mm3 is position 3"
   
    strMsg4 = "How many characters do you need to apply the change to?" & vbNewLine & vbNewLine
    strMsg4 = strMsg4 & "For example, to superscript the -3 in x10-3, 2 characters need changing"
   
    sScript = InputBox(strMsg)
     
    sTxt2Chng = InputBox(strMsg2)
   
        If InStr(sTxt2Chng, "<GR>a") <> 0 Then
            sFndStrng = Replace(sTxt2Chng, "<GR>a", ChrW(&H3B1))
        Else
            If InStr(sTxt2Chng, "<GR>b") <> 0 Then
                sFndStrng = Replace(sTxt2Chng, "<GR>b", ChrW(&H3B2))
            Else
                If InStr(sTxt2Chng, "<GR>g") <> 0 Then
                    sFndStrng = Replace(sTxt2Chng, "<GR>g", ChrW(&H3B3))
                Else
                    If InStr(sTxt2Chng, "<GR>d") <> 0 Then
                        sFndStrng = Replace(sTxt2Chng, "<GR>d", ChrW(&H3B4))
                    Else
                        If InStr(sTxt2Chng, "<GR>u-d") <> 0 Then
                            sFndStrng = Replace(sTxt2Chng, "<GR>u-d", ChrW(&H3B1))
                        Else
                            sFndStrng = sTxt2Chng
                        End If
                    End If
                End If
            End If
        End If
   
    c = InputBox(strMsg3)
    d = InputBox(strMsg4)
   
    TargetList = Array(sFndStrng)
   
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                Set txtRng = shp.TextFrame.TextRange


                For i = 0 To UBound(TargetList)
                    Set rngFound = txtRng.Find(TargetList(i))


                    Do While Not rngFound Is Nothing
                        n = rngFound.Start + 1
                        With rngFound.Characters(c, d)
                            If InStr(UCase(sScript), "SUP") <> 0 Then
                                .Font.Superscript = True
                            Else
                                If InStr(UCase(sScript), "SUB") <> 0 Then
                                    .Font.Subscript = True
                                End If
                            End If
                        End With
                        Set rngFound = txtRng.Find(TargetList(i), n)
                    Loop
                Next
            End If
        Next
    Next
End Sub

---

I think I've cracked it! Now all I have to do is try and work how to work with userforms to get rid of all of that horrible InputBox setup at the start. But for now, I think the following code does what I need it to.

Code:

---

Sub Advanced_Sub_Sup()
Dim sld As Slide, shp As Shape, iRows, iCol, iShp As Integer, txtRng As TextRange, rngFound As TextRange, oTbl As Table, i As Long, n As Long, c As Long, d As Long, sTargetList As String, sTxt2Chng As String, sFndStrng As String, sScript As String, sSupSub As Font, strMsg As String, strMsg2 As String, strMsg3 As String, strMsg4 As String, FndAt As String
   
    strMsg = "Make selected character superscript or subscript?" & vbNewLine & vbNewLine
    strMsg = strMsg & "Type" & vbTab & "Super" & vbTab & "for SUPERSCRIPT" & vbNewLine
    strMsg = strMsg & "Type" & vbTab & "Sub" & vbTab & "for SUBSCRIPT"
   
    strMsg2 = "Enter text example" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "Only needs to be a partial text string" & vbNewLine
    strMsg2 = strMsg2 & "For example, if you want to superscript the 3 in cells/mm3, just enter:" & vbTab & "mm3" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "To superscript a character AFTER alpha/beta/gamma/delta or DELTA" & vbNewLine
    strMsg2 = strMsg2 & "type <GR>a/b/g/d/u-d followed by the character to change" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "For example, if you want to indicate the beta symbol, enter:" & vbTab & "<GR>b"


    strMsg3 = "What position in your text string is the character?" & vbNewLine & vbNewLine
    strMsg3 = strMsg3 & "For example, the 2 in H20 is position 2, and the 3 in mm3 is position 3"
   
    strMsg4 = "How many characters do you need to apply the change to?" & vbNewLine & vbNewLine
    strMsg4 = strMsg4 & "For example, to superscript the -3 in x10-3, 2 characters need changing"
   
    sScript = InputBox(strMsg)
     
    sTxt2Chng = InputBox(strMsg2)
   
        If InStr(sTxt2Chng, "<GR>a") <> 0 Then
            sFndStrng = Replace(sTxt2Chng, "<GR>a", ChrW(&H3B1))
        Else
            If InStr(sTxt2Chng, "<GR>b") <> 0 Then
                sFndStrng = Replace(sTxt2Chng, "<GR>b", ChrW(&H3B2))
            Else
                If InStr(sTxt2Chng, "<GR>g") <> 0 Then
                    sFndStrng = Replace(sTxt2Chng, "<GR>g", ChrW(&H3B3))
                Else
                    If InStr(sTxt2Chng, "<GR>d") <> 0 Then
                        sFndStrng = Replace(sTxt2Chng, "<GR>d", ChrW(&H3B4))
                    Else
                        If InStr(sTxt2Chng, "<GR>u-d") <> 0 Then
                            sFndStrng = Replace(sTxt2Chng, "<GR>u-d", ChrW(&H3B1))
                        Else
                            sFndStrng = sTxt2Chng
                        End If
                    End If
                End If
            End If
        End If
   
    c = InputBox(strMsg3)
    d = InputBox(strMsg4)
   
    TargetList = Array(sFndStrng)
   
    On Error Resume Next
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTable Then
                Set oTbl = shp.Table
                    For iRows = 1 To oTbl.Rows.Count
                        For iCol = 1 To oTbl.Columns.Count
                            Set txtRng = oTbl.Cell(iRows, iCol).Shape.TextFrame.TextRange
                           
                            For i = 0 To UBound(TargetList)
                                Set rngFound = txtRng.Find(TargetList(i))
                               
                                Do While Not rngFound Is Nothing
                                    n = rngFound.Start + 1
                                    With rngFound.Characters(c, d)
                                        If InStr(UCase(sScript), "SUP") <> 0 Then
                                            .Font.Superscript = True
                                        Else
                                            If InStr(UCase(sScript), "SUB") <> 0 Then
                                                .Font.Subscript = True
                                            End If
                                        End If
                                    End With
                                    Set rngFound = txtRng.Find(TargetList(i), n)
                                Loop
                            Next
                        Next
                    Next
               
            Else
                If shp.Type = msoSmartArt Then
                    For iShp = 1 To shp.GroupItems.Count
                        Set txtRng = shp.GroupItems(iShp).TextFrame.TextRange
                       
                        For i = 0 To UBound(TargetList)
                            Set rngFound = txtRng.Find(TargetList(i))
                           
                            Do While Not rngFound Is Nothing
                                n = rngFound.Start + 1
                                With rngFound.Characters(c, d)
                                    If InStr(UCase(sScript), "SUP") <> 0 Then
                                        .Font.Superscript = True
                                    Else
                                        If InStr(UCase(sScript), "SUB") <> 0 Then
                                            .Font.Subscript = True
                                        End If
                                    End If
                                End With
                                Set rngFound = txtRng.Find(TargetList(i), n)
                            Loop
                        Next
                    Next iShp
                   
                    Else
                   
                        If shp.HasTextFrame Then
                            Set txtRng = shp.TextFrame.TextRange
           
                            For i = 0 To UBound(TargetList)
                                Set rngFound = txtRng.Find(TargetList(i))
           
                                Do While Not rngFound Is Nothing
                                    n = rngFound.Start + 1
                                    With rngFound.Characters(c, d)
                                        If InStr(UCase(sScript), "SUP") <> 0 Then
                                            .Font.Superscript = True
                                        Else
                                            If InStr(UCase(sScript), "SUB") <> 0 Then
                                                .Font.Subscript = True
                                            End If
                                        End If
                                    End With
                                    Set rngFound = txtRng.Find(TargetList(i), n)
                                Loop
                            Next
                        End If
                    End If
                End If
        Next
    Next
End Sub

---

Final, final update, I promise. Then I'll stop posting about this. But I thought I would post this in case this is useful to anyone else. As I say, this really needs a userform or two to neaten it up, instead of my bodges with inputboxes, but it's good enough for me. Many thanks to John Wilson and, by proxy, Shyam Pillai.

When this code runs, it will operate as, essentially, a find and replace for formatting text throughout a presentation. You get the option first to decide whether you want to change super/subscript for a user-defined string, or whether or you want to change more general formatting (bold, italic and underline) for a user-defined word or phrase.

Code:

---

Sub Format_find_replace()
    Dim sld As Slide, shp As Shape
    Dim iRows, iCol, iShp As Integer
    Dim txtRng, rngFound As TextRange
    Dim oTbl As Table
    Dim i, n, c, d As Long
    Dim fndrpl, sFrmt, sTxt2Chng, sFndStrng, sScript, strMsg, strMsg2, strMsg3, strMsg4, strMsg5, strMsg6, strMsg7 As String
   
    strMsg = "Make selected character superscript or subscript?" & vbNewLine & vbNewLine
    strMsg = strMsg & "Type" & vbTab & "Super" & vbTab & "for SUPERSCRIPT" & vbNewLine
    strMsg = strMsg & "Type" & vbTab & "Sub" & vbTab & "for SUBSCRIPT"
   
    strMsg2 = "Enter text example" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "Only needs to be a partial text string" & vbNewLine
    strMsg2 = strMsg2 & "For example, if you want to superscript the 3 in cells/mm3, just enter:" & vbTab & "mm3" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "To superscript a character AFTER alpha/beta/gamma/delta or DELTA" & vbNewLine
    strMsg2 = strMsg2 & "type <GR>a/b/g/d/u-d followed by the character to change" & vbNewLine & vbNewLine
    strMsg2 = strMsg2 & "For example, if you want to indicate the beta symbol, enter:" & vbTab & "<GR>b"


    strMsg3 = "What position in your text string is the character?" & vbNewLine & vbNewLine
    strMsg3 = strMsg3 & "For example, the 2 in H20 is position 2, and the 3 in mm3 is position 3"
   
    strMsg4 = "How many characters do you need to apply the change to?" & vbNewLine & vbNewLine
    strMsg4 = strMsg4 & "For example, to superscript the -3 in x10-3, 2 characters need changing"
   
    strMsg5 = "Do you want to find and replace formatting or" & vbNewLine
    strMsg5 = strMsg5 & "do you want to standardise super/subscript characters?" & vbNewLine & vbNewLine
    strMsg5 = strMsg5 & "F:" & vbTab & "for FORMATTING" & vbNewLine
    strMsg5 = strMsg5 & "S:" & vbTab & "for SUPER/SUBSCRIPT"
   
    strMsg6 = "Enter the text to find and replace" & vbNewLine & vbNewLine
    strMsg6 = strMsg6 & "NOTE: this will be applied to all instance of this text" & vbNewLine & vbNewLine
    strMsg6 = strMsg6 & "To include the greek letters: alpha/beta/gamma/delta or DELTA" & vbNewLine
    strMsg6 = strMsg6 & "type <GR>a/b/g/d/u-d, respectively" & vbNewLine & vbNewLine
    strMsg6 = strMsg6 & "For example, to include the capital delta symbol, enter:" & vbTab & "<GR>u-d"
   
    strMsg7 = "Enter format of text to re-style" & vbNewLine & vbNewLine
    strMsg7 = strMsg7 & "B:" & vbTab & "for Bold" & vbNewLine
    strMsg7 = strMsg7 & "I:" & vbTab & "for Italic" & vbNewLine
    strMsg7 = strMsg7 & "U:" & vbTab & "for Underline" & vbNewLine & vbNewLine
    strMsg7 = strMsg7 & "Combine letters for multiple (i.e. BIU)"
   
    fndrpl = InputBox(strMsg5, "Find and Replace Options")
        If fndrpl = "" Then End
       
    If InStr(UCase(fndrpl), "F") Then
        GoTo Formatting
    Else
        If InStr(UCase(fndrpl), "S") Then
            GoTo Scripting
        End If
    End If


Scripting:
    sScript = InputBox(strMsg)
        If sScript = "" Then End
     
    sTxt2Chng = InputBox(strMsg2)
        If sTxt2Chng = "" Then End
   
        If InStr(sTxt2Chng, "<GR>a") <> 0 Then
            sFndStrng = Replace(sTxt2Chng, "<GR>a", ChrW(&H3B1))
        Else
            If InStr(sTxt2Chng, "<GR>b") <> 0 Then
                sFndStrng = Replace(sTxt2Chng, "<GR>b", ChrW(&H3B2))
            Else
                If InStr(sTxt2Chng, "<GR>g") <> 0 Then
                    sFndStrng = Replace(sTxt2Chng, "<GR>g", ChrW(&H3B3))
                Else
                    If InStr(sTxt2Chng, "<GR>d") <> 0 Then
                        sFndStrng = Replace(sTxt2Chng, "<GR>d", ChrW(&H3B4))
                    Else
                        If InStr(sTxt2Chng, "<GR>u-d") <> 0 Then
                            sFndStrng = Replace(sTxt2Chng, "<GR>u-d", ChrW(&H3B1))
                        Else
                            sFndStrng = sTxt2Chng
                        End If
                    End If
                End If
            End If
        End If
   
    c = InputBox(strMsg3)
        If c < 1 Then End
       
    d = InputBox(strMsg4)
        If d < 1 Then End
   
    TargetList = Array(sFndStrng)
   
    On Error Resume Next
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTable Then
                Set oTbl = shp.Table
                    For iRows = 1 To oTbl.Rows.Count
                        For iCol = 1 To oTbl.Columns.Count
                            Set txtRng = oTbl.Cell(iRows, iCol).Shape.TextFrame.TextRange
                           
                            For i = 0 To UBound(TargetList)
                                Set rngFound = txtRng.Find(TargetList(i))
                               
                                Do While Not rngFound Is Nothing
                                    n = rngFound.Start + 1
                                    With rngFound.Characters(c, d)
                                        If InStr(UCase(sScript), "SUP") <> 0 Then
                                            .Font.Superscript = True
                                        Else
                                            If InStr(UCase(sScript), "SUB") <> 0 Then
                                                .Font.Subscript = True
                                            End If
                                        End If
                                    End With
                                    Set rngFound = txtRng.Find(TargetList(i), n)
                                Loop
                            Next
                        Next
                    Next
               
            Else
                If shp.Type = msoSmartArt Then
                    For iShp = 1 To shp.GroupItems.Count
                        Set txtRng = shp.GroupItems(iShp).TextFrame.TextRange
                       
                        For i = 0 To UBound(TargetList)
                            Set rngFound = txtRng.Find(TargetList(i))
                           
                            Do While Not rngFound Is Nothing
                                n = rngFound.Start + 1
                                With rngFound.Characters(c, d)
                                    If InStr(UCase(sScript), "SUP") <> 0 Then
                                        .Font.Superscript = True
                                    Else
                                        If InStr(UCase(sScript), "SUB") <> 0 Then
                                            .Font.Subscript = True
                                        End If
                                    End If
                                End With
                                Set rngFound = txtRng.Find(TargetList(i), n)
                            Loop
                        Next
                    Next iShp
                   
                    Else
                   
                        If shp.HasTextFrame Then
                            Set txtRng = shp.TextFrame.TextRange
           
                            For i = 0 To UBound(TargetList)
                                Set rngFound = txtRng.Find(TargetList(i))
           
                                Do While Not rngFound Is Nothing
                                    n = rngFound.Start + 1
                                    With rngFound.Characters(c, d)
                                        If InStr(UCase(sScript), "SUP") <> 0 Then
                                            .Font.Superscript = True
                                        Else
                                            If InStr(UCase(sScript), "SUB") <> 0 Then
                                                .Font.Subscript = True
                                            End If
                                        End If
                                    End With
                                    Set rngFound = txtRng.Find(TargetList(i), n)
                                Loop
                            Next
                        End If
                    End If
                End If
        Next
    Next
    GoTo Ending


Formatting:
    sTxt2Chng = InputBox(strMsg6, _
                "Find text")
                    If sTxt2Chng = "" Then End
   
        If InStr(sTxt2Chng, "<GR>a") <> 0 Then
            sFndStrng = Replace(sTxt2Chng, "<GR>a", ChrW(&H3B1))
        Else
            If InStr(sTxt2Chng, "<GR>b") <> 0 Then
                sFndStrng = Replace(sTxt2Chng, "<GR>b", ChrW(&H3B2))
            Else
                If InStr(sTxt2Chng, "<GR>g") <> 0 Then
                    sFndStrng = Replace(sTxt2Chng, "<GR>g", ChrW(&H3B3))
                Else
                    If InStr(sTxt2Chng, "<GR>d") <> 0 Then
                        sFndStrng = Replace(sTxt2Chng, "<GR>d", ChrW(&H3B4))
                    Else
                        If InStr(sTxt2Chng, "<GR>u-d") <> 0 Then
                            sFndStrng = Replace(sTxt2Chng, "<GR>u-d", ChrW(&H3B1))
                        Else
                            sFndStrng = sTxt2Chng
                        End If
                    End If
                End If
            End If
        End If


    sFrmt = InputBox(strMsg7, _
            "Format options")
            If sFrmt = "" Then End
   
    TargetList = Array(sFndStrng)
   
    On Error Resume Next
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTable Then
                Set oTbl = shp.Table
                    For iRows = 1 To oTbl.Rows.Count
                        For iCol = 1 To oTbl.Columns.Count
                            Set txtRng = oTbl.Cell(iRows, iCol).Shape.TextFrame.TextRange
                           
                            For i = 0 To UBound(TargetList)
                                Set rngFound = txtRng.Find(TargetList(i))
                               
                                Do While Not rngFound Is Nothing
                                    n = rngFound.Start + 1
                                    With rngFound.Font
                                        If InStr(UCase(sFrmt), "B") <> 0 Then
                                            .Bold = True
                                        End If
                                        If InStr(UCase(sFrmt), "I") <> 0 Then
                                            .Italic = True
                                        End If
                                        If InStr(UCase(sFrmt), "U") <> 0 Then
                                            .Underline = True
                                        End If
                                    End With
                                    Set rngFound = txtRng.Find(TargetList(i), n)
                                Loop
                            Next
                        Next
                    Next
               
            Else
                If shp.Type = msoSmartArt Then
                    For iShp = 1 To shp.GroupItems.Count
                        Set txtRng = shp.GroupItems(iShp).TextFrame.TextRange
                       
                        For i = 0 To UBound(TargetList)
                            Set rngFound = txtRng.Find(TargetList(i))
                           
                            Do While Not rngFound Is Nothing
                                n = rngFound.Start + 1
                                    With rngFound.Font
                                        If InStr(UCase(sFrmt), "B") <> 0 Then
                                            .Bold = True
                                        End If
                                        If InStr(UCase(sFrmt), "I") <> 0 Then
                                            .Italic = True
                                        End If
                                        If InStr(UCase(sFrmt), "U") <> 0 Then
                                            .Underline = True
                                        End If
                                End With
                                Set rngFound = txtRng.Find(TargetList(i), n)
                            Loop
                        Next
                    Next iShp
                   
                    Else
                   
                        If shp.HasTextFrame Then
                            Set txtRng = shp.TextFrame.TextRange
           
                            For i = 0 To UBound(TargetList)
                                Set rngFound = txtRng.Find(TargetList(i))
           
                                Do While Not rngFound Is Nothing
                                    n = rngFound.Start + 1
                                    With rngFound.Font
                                        If InStr(UCase(sFrmt), "B") <> 0 Then
                                            .Bold = True
                                        End If
                                        If InStr(UCase(sFrmt), "I") <> 0 Then
                                            .Italic = True
                                        End If
                                        If InStr(UCase(sFrmt), "U") <> 0 Then
                                            .Underline = True
                                        End If
                                    End With
                                    Set rngFound = txtRng.Find(TargetList(i), n)
                                Loop
                            Next
                        End If
                    End If
                End If
        Next
    Next
    GoTo Ending


Ending:
End Sub

---