Nice. I cut it down to columns only. This works nicely.

Sub double_2Col()
Dim MyRange As Range
Set MyRange = Selection
NumRows = MyRange.Rows.Count
NumCols = MyRange.Columns.Count
LastRow = MyRange.Row + NumRows - 1
LastCol = MyRange.Column + NumCols - 1
For ColCount = LastCol To MyRange.Column Step -1
Set FormulaRange = Range(Cells(MyRange.Row, ColCount + 1), Cells
(LastRow, ColCount + 1))
FormulaRange.FormulaR1C1 = "=RC[-1]/2+RC[+1]/2"
If ColCount < MyRange.Column Then
Set InsertRange = Range(Cells(MyRange.Row, ColCount), Cells
(LastRow, ColCount))
InsertRange.Insert shift:=xlToRight
End If
Next ColCount
End Sub
__________________________________________________ _________________

I tried to modify it to do rows with a formula. I get something
looking like a Chinese puzzle. Where an I going wrong?

Sub double__Row()
Dim MyRange As Range
Set MyRange = Selection
NumRows = MyRange.Rows.Count
NumCols = MyRange.Columns.Count
LastRow = MyRange.Row + NumRows
LastCol = MyRange.Column + NumCols - 1
For RowCount = LastRow To (MyRange.Row + 1) Step -1
Set FormulaRange = Range(Cells(MyRange.Column, RowCount + 1), Cells
(LastCol, RowCount + 1))
FormulaRange.FormulaR1C1 = "=R[-1]C/2+R[1]C/2"
If RowCount < MyRange.Row Then
Set InsertRange = Range(Cells(RowCount, MyRange.Column), Cells
(RowCount, LastCol))
InsertRange.Insert shift:=xlDown
End If
Next RowCount
End Sub