Sub Demo()
Application.ScreenUpdating = False
Dim t As Long, r As Long, c As Long, i As Long, Rng As Range, StrTmp As String
With ActiveDocument
  For t = 1 To .Tables.Count
    With .Tables(t)
      .AllowAutoFit = False
      With .Range.Font
        .Name = "Arial"
        .Size = 7
      End With
      .Rows.HeightRule = wdRowHeightExactly
      .Rows.Height = 10
      With .Range.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
      End With
      For r = 1 To .Rows.Count
        With .Rows(r)
          If .Cells.Count > 5 Then
            Set Rng = .Range
            Rng.Start = .Cells(6).Range.Start
            Rng.Cells.Delete
          End If
          Do While Split(.Cells(.Cells.Count).Range.Text, vbCr)(0) = ""
            .Cells(.Cells.Count).Delete
          Loop
          i = .Cells.Count
          If i < 5 Then
            Set Rng = .Range
            With .Range.Tables(1)
              If r < .Rows.Count Then .Split .Rows(r + 1)
              .Split .Rows(r)
              .Rows.Add
            End With
            Select Case i
              Case 1
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
                .Cells(5).Range.Text = Split(StrTmp, vbTab)(2)
              Case 2
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 2).Range.Text, vbCr)(0)
                If InStr(StrTmp, vbTab) > 0 Then
                  .Cells(4).Range.Text = Split(StrTmp, vbTab)(UBound(Split(StrTmp, vbTab)) - 1)
                End If
                .Cells(5).Range.Text = Split(StrTmp, vbTab)(UBound(Split(StrTmp, vbTab)))
              Case 3
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
              Case 4
                StrTmp = Split(Rng.Tables(2).Cell(1, 1).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(1).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 2).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(2).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 3).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(4).Range.Text = Split(StrTmp, vbTab)(0)
                StrTmp = Split(Rng.Tables(2).Cell(1, 4).Range.Text, vbCr)(0)
                If StrTmp <> "" Then .Cells(5).Range.Text = Split(StrTmp, vbTab)(0)
            End Select
            .Range.Tables(1).Rows(r).Range.Font.Bold = Not IsNumeric(Split(.Cells(.Cells.Count).Range.Text, vbCr)(0))
            With Rng
              .End = .Tables(2).Range.End + 1
              .Start = .Tables(2).Range.Start - 1
              .Delete
            End With
          End If
        End With
      Next
    End With
    DoEvents
  Next
End With
Application.ScreenUpdating = True
End Sub