Sub Demo()
Dim wdDoc As Document, Tbl As Table, Rng As Range, i As Long, j As Long, k As Long
Application.ScreenUpdating = False
Set wdDoc = ActiveDocument
With wdDoc
  For i = .Tables.Count To 1 Step -1
    With .Tables(i).Range
      j = (.Cells(.Cells.Count).RowIndex - 1) / 2
      .Paragraphs.Last.Next.Range.InsertBefore vbCr & vbCr & vbCr & vbCr
      Set Rng = .Paragraphs.Last.Next.Next.Range
      Rng.Collapse wdCollapseStart
      Set Tbl = wdDoc.Tables.Add(Range:=Rng, NumRows:=2, NumColumns:=4, AutoFitBehavior:=False)
      With Tbl
        .Borders.Enable = True
        .Rows.HeightRule = wdRowHeightExactly
        .Rows(1).Height = InchesToPoints(0.25)
        .Rows(2).Height = InchesToPoints(0.5)
        .Cell(2, 1).VerticalAlignment = wdCellAlignVerticalCenter
        .Columns.PreferredWidthType = wdPreferredWidthPoints
        .Rows(1).Shading.BackgroundPatternColorIndex = wdTurquoise
        .Columns(1).Shading.BackgroundPatternColorIndex = wdTurquoise
        .Columns(1).Width = InchesToPoints(0.45)
        .Columns(2).Width = InchesToPoints(1.5)
        .Columns(3).Width = InchesToPoints(2.38)
        .Columns(4).Width = InchesToPoints(2.33)
        Set Rng = .Range
        With Rng
          .SetRange Start:=.Cells(6).Range.Start, End:=.Cells(8).Range.End
          .Cells.Split NumRows:=2, NumColumns:=1, MergeBeforeSplit:=False
          .Rows.HeightRule = wdRowHeightExactly
          .Cells.Height = InchesToPoints(0.25)
          .SetRange Start:=Tbl.Range.Cells(9).Range.Start, End:=Tbl.Range.End
          .Cells.Merge
          .SetRange Start:=Tbl.Range.Cells(5).Range.Start, End:=Tbl.Range.End
          .Copy
        End With
        For k = 2 To j
          With .Range.Paragraphs.Last.Next.Range
            .InsertBefore vbCr
            .Paste
          End With
        Next
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub