Sub FormatScientificNamesByExcel()

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

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

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:=False) = True

Set Rng = Selection.range

Selection.Collapse wdCollapseEnd

Rng.Font.Italic = True

Loop

End With

Next i

End Sub