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