[kejo]

very nice
you have a deep experience in this field.

your last piece of code is working like a charm:

Sub ChangeColor01()

ActiveDocument.ConvertNumbersToText

For Each vWord In ActiveDocument.Words

If vWord.Underline = 1 Then
    
    vWord.Select
    Selection.HomeKey Unit:=wdLine

    If IsEmpty(vStart) Then
        vStart = Selection.Information(wdHorizontalPositionRelativeToPage)
    End If

    If Selection.Information(wdHorizontalPositionRelativeToPage) = vStart Then
        Do Until InStr(1, Selection.Text, ".") > 0
        Selection.MoveRight Unit:=wdCharacter, count:=1, Extend:=wdExtend
        Loop
        Selection.Font.Color = wdColorRed
    Else
        GoTo Skip
    End If
    
End If
Skip:
Next

End Sub

thank you very much man.

by the way: what office version are you running?

[Rollin_Again]

I am still running Office 2000. I have Office 2003 on disk but I am lazy and was never in a hurry to install it since the older version works fine for everything I do.

Regards,
Rollin

[kejo]

is there a way to run this macro for all the .doc files in my folder ??

[Rollin_Again]

Yes. Does the folder in question contain any other files other than Word files that need to be processed by the macro?

Regards,
Rollin

[kejo]

only my docs....

[Rollin_Again]

What version of MS Word / Office are you using??

Regards,
Rollin

[kejo]

i am using 2003, but i have 2007 too

[Rollin_Again]

Here is the updated code

Sub LoopDirectory()

Application.FileDialog(msoFileDialogFolderPicker).Show
vDirectory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

If Len(Dir(vDirectory & "\" & "NewFiles", vbDirectory)) = 0 Then
    MkDir vDirectory & "\" & "NewFiles"
End If

vFile = Dir(vDirectory & "\" & "*.*")

Do While vFile <> ""

    Documents.Open FileName:=vDirectory & "\" & vFile

ActiveDocument.ConvertNumbersToText

For Each vWord In ActiveDocument.Words

If vWord.Underline = 1 Then
    
    vWord.Select
    Selection.HomeKey Unit:=wdLine

    If IsEmpty(vStart) Then
        vStart = Selection.Information(wdHorizontalPositionRelativeToPage)
    End If

    If Selection.Information(wdHorizontalPositionRelativeToPage) = vStart Then
        Do Until InStr(1, Selection.Text, ".") > 0
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Loop
        Selection.Font.Color = wdColorRed
    Else
        GoTo Skip
    End If
    
End If
Skip:
Next


ActiveDocument.SaveAs (vDirectory & "\" & "NewFiles" & "\" & ActiveDocument.Name)
ActiveDocument.Close

vFile = Dir
Loop

End Sub

Regards,
Rollin