Sub TOCshrinker()
  Dim aTOC As TableOfContents, aRng As Range, aPara As Paragraph, iPara As Integer, aFld As Field
  If ActiveDocument.TablesOfContents.Count = 0 Then
    Set aRng = ActiveDocument.Range(0, 0)
    Set aTOC = ActiveDocument.TablesOfContents.Add(Range:=aRng, UseOutlineLevels:=True, UpperHeadingLevel:=1, LowerHeadingLevel:=3, RightAlignPageNumbers:=False, UseHyperlinks:=True)
  Else
    Set aTOC = ActiveDocument.TablesOfContents(1)
  End If
  With aTOC
    .Range.Fields(1).Locked = False
    .Update
    For iPara = aTOC.Range.Paragraphs.Count To 1 Step -1
      Set aPara = aTOC.Range.Paragraphs(iPara)
      If aPara.Style = "TOC 2" And aPara.Next.Style = "TOC 2" Then
        aPara.Range.Characters.Last = ", "
      End If
    Next iPara
    .Range.Fields(1).Locked = True
  End With
End Sub