Sub Demo()
Application.ScreenUpdating = False
Dim wdDoc As Document, Tbl As Table, sWdth(), i As Long, Rng As Range
'Store all the widths used. 1st item = table width
'2nd - 5th items = individual cell widths
'6th item = sum of of 3rd - 5th items
sWdth = Array(6.66, 0.45, 1.5, 2.38, 2.33, 6.21)
Set wdDoc = ActiveDocument
With wdDoc
  For Each Tbl In .Tables
    With Tbl
      'Give the cells an all-round interior padding
      .TopPadding = InchesToPoints(0.05)
      .BottomPadding = InchesToPoints(0.05)
      .LeftPadding = InchesToPoints(0.05)
      .RightPadding = InchesToPoints(0.05)
      .Spacing = 0
      'Switch off autofit
      .AllowAutoFit = False
      'set the preferred width type
      .PreferredWidthType = wdPreferredWidthPoints
      'set the preferred width value to the specified array value
      .PreferredWidth = InchesToPoints(sWdth(0))
      With .Rows
        'Remove any table indenting
        .LeftIndent = 0
        'Center the table on the page
        .Alignment = wdAlignRowCenter
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
        'Give the cells automatic heights, so they'll fit their contents
        .HeightRule = wdRowHeightAuto
      End With
      With .Range
        'Ensure the first row functions as a heading row
        .Cells(1).Select: Selection.Rows.HeadingFormat = True
        'Format the first four cells
        For i = 1 To 4
          .Cells(i).Width = InchesToPoints(sWdth(i))
        Next
        'Format the remaining cells, in groups of 5.
        'The first cell in each group spans two rows and
        'the first row in each group contains 4 cells but
        'the second row contains 1 cell spanning the width
        'of the last 3 cells of the first row
        For i = 5 To .Cells.Count
          'If it's the first cell in a group, ensure it's both merged and centred vertically
          If ((i Mod 5) + 1) = 1 Then
            If .Cells(i + 4).ColumnIndex = 1 Then
              Set Rng = .Cells(i).Range
              Rng.End = .Cells(i + 4).Range.End
              Rng.Select: Selection.Cells.Merge
            End If
            .Cells(i).VerticalAlignment = wdCellAlignVerticalCenter
          End If
          'Specify a minimum height for the last cell in the group
          If ((i Mod 5) + 1) = 5 Then
            .Cells(i).SetHeight Rowheight:=InchesToPoints(0.5), HeightRule:=wdRowHeightAtLeast
          End If
          .Cells(i).Width = InchesToPoints(sWdth((i Mod 5) + 1))
          'If we've merged any cells, the count will have changed
          If i = .Cells.Count Then Exit For
        Next
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub