I have this VBA code, which was developed by DougRobbin
This code Format Scientific Names which are present in the main body of the document and in the text boxes in a word document according to the list of microbial names in Excel file.
Now I want the same code for the same purpose, but to work inside PowerPoint,
Nowadays I made many seminars, which include microbial names and I change formatting for each one manually, which is so annoying.
So I want a code to do this automatically in PowerPoint.
Thanks
Code:
Sub FormatByExcel()
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim myarray As Variant
Dim FD As FileDialog
Dim strSource As String
Dim i As Long, lognum As Long
Dim myStoryRange As range
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Title = "Select the workbook that contains the terms to be italicized"
.Filters.Clear
.Filters.Add "Excel Workbooks", "*.xlsx"
.AllowMultiSelect = False
If .Show = -1 Then
strSource = .SelectedItems(1)
Else
MsgBox "You did not select the workbook that contains the data"
Exit Sub
End If
End With
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
bStartApp = True
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlbook = xlapp.Workbooks.Open(strSource)
Set xlsheet = xlbook.Worksheets(1)
myarray = xlsheet.range("A1").CurrentRegion.Value
If bStartApp = True Then
xlapp.Quit
End If
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
Application.ScreenUpdating = False
For i = LBound(myarray) To UBound(myarray)
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findText:=myarray(i, 1), Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True
Set Rng = Selection.range
Selection.Collapse wdCollapseEnd
Rng.Font.Italic = True
Loop
End With
For Each myStoryRange In ActiveDocument.StoryRanges
myStoryRange.Select
With Selection.Find
Do While .Execute(findText:=myarray(i, 1), Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True
Set Rng = Selection.range
Selection.Collapse wdCollapseEnd
Rng.Font.Italic = True
Loop
End With
Do While Not (myStoryRange.NextStoryRange Is Nothing)
Set myStoryRange = myStoryRange.NextStoryRange
myStoryRange.Select
With Selection.Find
Do While .Execute(findText:=myarray(i, 1), Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=True) = True
Set Rng = Selection.range
Selection.Collapse wdCollapseEnd
Rng.Font.Italic = True
Loop
End With
Loop
Next myStoryRange
Next i
With Application
.ScreenUpdating = True
.ScreenRefresh
.ActiveWindow.View = wdPrintView
End With
End Sub