That last addition will help. There are still some tables that don't work exactly right, which is a problem with the documents not the macro. How would you finish the original macro so that it moves the data from the original table into the new one while using the selected range option? I think I got the right code below and tried incorporating the selection part, but it's not working.
Code:
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 RngSel = Selection.Range
With RngSel
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 = wdRowHeightAuto
.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 = wdRowHeightAuto
.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