Insert column, move data with VBA

[Fred]

Ok here is what I have:

Columns with several rows of names followed by several rows of numbers,
I need to cut the numbers out, insert a new column and paste them in
the new column. I have tried several things but can't quite get it. I
have many columns to do this with so I need to loop through a range
thanks!!
Fred

BEFORE:
A B
---------------------
Fred Amy
Dave Jan
Sam Bev
Doug Carol
1 1
2 2
3 3
4 4
5 5
6 6

AFTER:
A B C D
------------------------------------------
Fred 1 Amy 1
Dave 2 Jan 2
Sam 3 Bev 3
Doug 4 Carol 4
5 5
6 6

 

[Tom Ogilvy]

Dim lastcol as Long, i as long, rng as Range
lastcol = cells(1,"IV").End(xltoleft).Column
for i = lastcol to 1 step -1
columns(i+1).Insert
Set rng = Nothing
On Error Resume Next
set rng = columns(i).SpecialCells(xlconstants,xlnumbers)
On Error goto 0
if not rng is nothing then
rng.copy cells(i+1,1)
rng.Clearcontents
end if
Next

 

[Fred]

Thanks Tom... the columns insert fine but the numbers do not move they
just disappear... any ideas?
Fred

 

[Tom Ogilvy]

Sorry, had a typo:

Sub efg()
Dim lastcol As Long, i As Long, rng As Range
lastcol = Cells(1, "IV").End(xlToLeft).Column
For i = lastcol To 1 Step -1
Columns(i + 1).Insert
Set rng = Nothing
On Error Resume Next
Set rng = Columns(i).SpecialCells(xlConstants, xlNumbers)
On Error GoTo 0
If Not rng Is Nothing Then
rng.Copy Cells(1, i + 1)
rng.ClearContents
End If
Next

End Sub

 

[Fred]

Tom you are awesome as usual!! That worked perfect!! Thanks again!!

Fred