Try the following macro:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim Para As Paragraph, i As Long, j As Long
Dim StrTxt As String, StrTmp As String, StrFnd As String
With ActiveDocument
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.MatchCase = False
.Wrap = wdFindContinue
.MatchWildcards = False
.Text = " )"
.Replacement.Text = ")"
.Execute Replace:=wdReplaceAll
.Text = "( "
.Replacement.Text = "("
.Execute Replace:=wdReplaceAll
.Text = " ,"
.Replacement.Text = ","
.Execute Replace:=wdReplaceAll
.Text = ", "
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
.Text = ",{2,}"
.Execute Replace:=wdReplaceAll
.Text = "^13{2,}"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
For Each Para In .Paragraphs
StrTxt = Para.Range.Text: StrFnd = ""
StrTxt = Replace(Replace(Replace(StrTxt, "(", ","), ")", ","), vbCr, "")
Do While InStr(StrTxt, ", ") > 0
StrTxt = Replace(StrTxt, ", ", ",")
Loop
Do While InStr(StrTxt, " ,") > 0
StrTxt = Replace(StrTxt, " ,", ",")
Loop
Do While InStr(StrTxt, ",,") > 0
StrTxt = Replace(StrTxt, ",,", ",")
Loop
For i = 1 To UBound(Split(StrTxt, ","))
j = Len(StrTxt)
StrTmp = Split(StrTxt, ",")(i)
If StrTmp <> "" Then
StrTxt = Replace(StrTxt, StrTmp, "")
If (j - Len(StrTxt)) > Len(StrTmp) Then StrFnd = StrFnd & "," & StrTmp
End If
Next
If StrFnd <> "" Then
For i = 1 To UBound(Split(StrFnd, ","))
StrTmp = Split(StrFnd, ",")(i)
With Para.Range
.Start = .Start + InStr(.Text, StrTmp) + Len(StrTmp)
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.MatchCase = False
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Text = StrTmp & ","
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
.Text = StrTmp & "^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
End With
Next
End If
Next
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.MatchCase = False
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = " ,"
.Replacement.Text = ","
.Execute Replace:=wdReplaceAll
.Text = ", "
.Execute Replace:=wdReplaceAll
.Text = ",{2,}"
.Execute Replace:=wdReplaceAll
.Text = ","
.Replacement.Text = ", "
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
Note: Three times in the code, you will see {2,}. Depending on your system's regional settings you may need to change these to {2;}.
The code also does some tidying-up of your text.