Sub SourceTableReformat()
Application.ScreenUpdating = False
Dim r As Long, x As Long, y As Long, Rng As Range, StrTxt As String
With ActiveDocument.Tables(1)
  For r = .Rows.Count To 2 Step -1
    With .Rows(r)
      StrTxt = Split(.Cells(4).Range.Text, vbCr)(0)
      x = UBound(Split(StrTxt, ","))
      If x > 0 Then
        Set Rng = .Range
        For y = 1 To x - 1
          Rng.Collapse wdCollapseEnd
          Rng.FormattedText = .Range.FormattedText
          Rng.Cells(4).Range.Text = Trim(Split(StrTxt, ",")(y))
        Next
        .Cells(4).Range.Text = Trim(Split(StrTxt, ",")(0))
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub