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