Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
Randomize Timer
With ActiveDocument
  For i = 1 To .Characters.Count
    .Characters(i).Font.Color = Int(Rnd * 1048576)
  Next
End With
Application.ScreenUpdating = True
End Sub

Sub MyRandCharColors16M_Augment()
Dim oCol As New Collection
Dim lngColor As Long
Dim oChr As Range
Dim sngR As Single, sngG As Single, snbB As Single
Dim sngRGBSum As Single, sngRGBF As Single
Application.ScreenUpdating = False
'Define the maximum RGB sum. A score around 500-600 seems to give the best results.
Const sngRGBMax As Single = 550
Randomize
'Loop thru characters in document.
For Each oChr In ActiveDocument.Range.Characters
Dup_Reentry:
  sngR = Int(Rnd() * 256)
  sngG = Int(Rnd() * 256)
  snbB = Int(Rnd() * 256)
  'If the sum > max, scale all three back proportionately
  sngRGBSum = sngR + sngG + snbB
  If sngRGBSum > sngRGBMax Then
    sngRGBF = sngRGBMax / sngRGBSum
    sngR = sngR * sngRGBF
    sngG = sngG * sngRGBF
    snbB = snbB * sngRGBF
  End If
  'Assign the character its color
  lngColor = RGB(sngR, sngG, snbB)
  On Error GoTo Err_Duplicate
  oCol.Add CStr(lngColor), CStr(lngColor)
  oChr.Font.Color = lngColor
Next oChr
Application.ScreenUpdating = True
Exit Sub
Err_Duplicate:
  Resume Dup_Reentry
  Beep
End Sub