Sub smArtCollector2()
' Paul Beverley - Version 28.01.20
' Find something specific and do things to each one

wcFind = "<[Aa]rt[a-zA-Z 0-9.]{1,}[;\)^13]"

Set rng = ActiveDocument.Content
Documents.Add
Selection.Text = rng.Text
Set tempDoc = ActiveDocument


Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "\(([0-9]{1,})\)"
  .Wrap = wdFindContinue
  .Replacement.Text = "qcqc\1vqvq"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "\[([0-9]{1,})\]"
  .Wrap = wdFindContinue
  .Replacement.Text = "vcvc\1cxcx"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
End With

Documents.Add
Set rng2 = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = wcFind
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

myCount = 0
Do While rng.Find.Found = True
  endNow = rng.End
  rng2.InsertAfter Text:=rng.Text & vbCr
  rng.Start = endNow
  rng.Find.Execute
  DoEvents
Loop

fText = "qcqc,vqvq,vcvc,cxcx"
rText = "(,),[,]"
f = Split(fText, ",")
r = Split(rText, ",")

For i = 0 To UBound(f)
  With rng2.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = f(i)
    .Wrap = wdFindContinue
    .Replacement.Text = r(i)
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    DoEvents
  End With
Next i

tempDoc.Close SaveChanges:=False
Beep
End Sub