Sub PunctuationBoldOff()
' Paul Beverley - Version 06.10.21
' Un-bolds all commas, etc. not followed by bold text

stayBoldColour = wdYellow
' stayBoldColour = wdNoHighlight

changeToRomanColour = wdYellow
trackIt = False

myTrack = ActiveDocument.TrackRevisions
If trackIt = False Then ActiveDocument.TrackRevisions = False
myCount = 0
Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[,:;.]"
  .Font.Bold = True
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

Do While rng.Find.Found = True
' If you want to count them...
' Note where the end of the found item is
  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.Bold = False)
  rng.Start = endNow - 1
  rng.End = endNow
  
  If makeRoman Then
    rng.Font.Bold = False
    rng.HighlightColorIndex = changeToRomanColour
    myCount = myCount + 1
  Else
    If stayBoldColour > 0 Then rng.HighlightColorIndex = stayBoldColour
  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.Bold = True
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchWildcards = True
    .Execute
  End With

  Do While rng.Find.Found = True
  ' If you want to count them...
  ' Note where the end of the found item is
    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.Bold = False)
    rng.Start = endNow - 1
    rng.End = endNow
    
    If makeRoman Then
      rng.Font.Bold = False
      rng.HighlightColorIndex = changeToRomanColour
      myCount = myCount + 1
    Else
      If stayBoldColour > 0 Then rng.HighlightColorIndex = stayBoldColour
    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.Bold = 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.Bold = False)
    rng.Start = endNow - 1
    rng.End = endNow
    
    If makeRoman Then
      rng.Font.Bold = False
      rng.HighlightColorIndex = changeToRomanColour
      myCount = myCount + 1
    Else
      If stayBoldColour > 0 Then rng.HighlightColorIndex = stayBoldColour
    End If
    rng.Start = endNow
    rng.End = endNow
    rng.Find.Execute
  Loop
End If

MsgBox "Changed bold to roman: " & myCount
ActiveDocument.TrackRevisions = myTrack
End Sub