Sub PunctuationItalicOff()
' Paul Beverley - Version 20.01.23
' Un-italicises all commas etc not followed by italic text

' stayItalicColour = wdNoHighlight
stayItalicColour = wdYellow

changeToRomanColour = wdGray25
trackIt = False

myCount = 0
myTrack = ActiveDocument.TrackRevisions
If trackIt = False Then ActiveDocument.TrackRevisions = False

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[,:;.""'\)]"
  .Font.Italic = True
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

Do While rng.Find.Found = True
  endNow = rng.End
  rng.Start = rng.End
  rng.End = rng.End + 1
  
  If rng.Text = " " Then
    rng.Start = rng.End
    rng.End = rng.End + 1
  End If
  
  makeRoman = (rng.Font.Italic = False)
  rng.Start = endNow - 1
  rng.End = endNow
  
  If makeRoman Then
    rng.Font.Italic = False
    rng.HighlightColorIndex = changeToRomanColour
    myCount = myCount + 1
  Else
    If stayItalicColour > 0 Then rng.HighlightColorIndex = stayItalicColour
  End If
  rng.Start = endNow
  rng.End = endNow
  rng.Find.Execute
Loop

If ActiveDocument.Endnotes.count > 0 Then
  Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[,:;.""'\)]"
    .Font.Italic = True
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchWildcards = True
    .Execute
  End With
  
  Do While rng.Find.Found = True
    endNow = rng.End
    rng.Start = rng.End
    rng.End = rng.End + 1
    
    If rng.Text = " " Then
      rng.Start = rng.End
      rng.End = rng.End + 1
    End If
    
    makeRoman = (rng.Font.Italic = False)
    rng.Start = endNow - 1
    rng.End = endNow
    
    If makeRoman Then
      rng.Font.Italic = False
      rng.HighlightColorIndex = changeToRomanColour
      myCount = myCount + 1
    Else
      If stayItalicColour > 0 Then rng.HighlightColorIndex = stayItalicColour
    End If
    rng.Start = endNow
    rng.End = endNow
    rng.Find.Execute
  Loop
End If
If ActiveDocument.Footnotes.count > 0 Then
  Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[,:;.""'\)]"
    .Font.Italic = True
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchWildcards = True
    .Execute
  End With
  
  Do While rng.Find.Found = True
    endNow = rng.End
    rng.Start = rng.End
    rng.End = rng.End + 1
    
    If rng.Text = " " Then
      rng.Start = rng.End
      rng.End = rng.End + 1
    End If
    
    makeRoman = (rng.Font.Italic = False)
    rng.Start = endNow - 1
    rng.End = endNow
    
    If makeRoman Then
      rng.Font.Italic = False
      rng.HighlightColorIndex = changeToRomanColour
      myCount = myCount + 1
    Else
      If stayItalicColour > 0 Then rng.HighlightColorIndex = stayItalicColour
    End If
    rng.Start = endNow
    rng.End = endNow
    rng.Find.Execute
  Loop
End If
MsgBox "Changed italic to roman: " & myCount
ActiveDocument.TrackRevisions = myTrack
End Sub