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