MS Word macro to correct partially formatted words

Question

I made a macro that replaces all characters in a text, from old transcription fonts to a unicode font. I don't know why, but some characters keep the original formatting, while others lose the formatting (in my case, mostly italics), often within the same word. This leaves me with a lot of words in which some letters are italicized, and other letters aren't (e.g., "al-Malik al-Muǧāhid ḫuṭba"). The characters that lose the formatting are all characters with diacritics, but not all characters with diacritics lose their formatting (e.g., the ḫ in the example).

What would be the best way to find all words that have at least one letter in italics, and apply italics formatting to all those words?

If someone could point me to a solution for the original problem, that would of course be even better (but that is the subject of another question: some characters lose formatting in vba macro others don't).

Answer 1

The below code answers the question of 'find all words that have at least one letter in italics, and apply italics formatting to all those words'

I've added comments to describe what is happening. I've automated Word a lot and I find it to have a lot of quirks, so the below worked in a simple test but you should test thoroughly before releasing code into the wild.

Public Sub Sample()
Dim WdDoc   As Word.Document
Dim WdSlct  As Word.Selection
Dim WdFnd   As Word.Find
Set WdDoc = ThisDocument
    WdDoc.Content.Select
    Set WdSlct = Selection
        WdSlct.SetRange 0, 0
        Set WdFnd = WdSlct.Find

            'Clear any previous find settings
            WdFnd.ClearAllFuzzyOptions
            WdFnd.ClearFormatting
            WdFnd.ClearHitHighlight

            'Set the find to look for italic text
            WdFnd.Font.Italic = True

            'Look for any italic character
            Do Until Not WdFnd.Execute(FindText:="?", MatchWildcards:=True, Forward:=True, Wrap:=wdFindStop, Format:=True, Replace:=wdReplaceNone)

                'Expand the selection to the whole word
                WdSlct.Expand wdWord

                'Set the word to be italic
                WdSlct.Font.Italic = True

                'Move past the word
                WdSlct.SetRange WdSlct.End, WdSlct.End
            Loop
        Set WdFnd = Nothing
    Set WdSlct = Nothing
Set WdDoc = Nothing
End Sub

---

Adapted from edit request from @peterv (the OP)

To make this work in footnotes, headers and other storyranges, I adapted Gary's solution by combining it with this trick:

Sub RemedyPartialItalics()
Dim WdDoc   As Word.Doc
Dim WdFnd   As Word.Find
Dim WdRng   As Word.Range
Dim WdSlct  As Word.Selection
Set WdDoc = ActiveDocument
    For Each WdRng In WdDoc.StoryRanges
        wdRng.Select
        Set WdSlct = Selection
            WdSlct.SetRange 0, 0
            Set WdFnd = WdSlct.Find
                WdFnd.ClearAllFuzzyOptions
                WdFnd.ClearFormatting
                WdFnd.ClearHitHighlight
                WdFnd.Font.Italic = True
                Do Until Not WdFnd.Execute(FindText:="?", MatchWildcards:=True, Forward:=True, Wrap:=wdFindStop, Format:=True, Replace:=wdReplaceNone)
                    WdSlct.Expand wdWord
                    WdSlct.Font.Italic = True
                    WdSlct.SetRange WdSlct.End, WdSlct.End
                Loop
            Set WdFnd = Nothing
        Set WdSlct = Nothing
    Next
End Sub