Try:
Code:
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
I don't know what you want to do about row heights, since setting them to a fixed size could compromise the display of their content, so I've just made their heights automatic, except for the last cell in each group, which has a minimum specified height, so that all cells will fit whatever content is there. I've also applied small interior margins to the cells, to keep the text away from the borders and all tables should now be horizontally centred on the page.