Going through every instance of a string in text boxes

[h2whoa]

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 β2 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 β2?

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!

[John Wilson]

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


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

[h2whoa]

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!

[h2whoa]

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:



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

[h2whoa]

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.



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

[h2whoa]

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.



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