Insert Pictures Macro, going across Row, pic above Referenced Item #

First Thanks for you help.

I have a macro (I did not write, but understand most of it) It pulls in pictures from a web server and places the picture in a column of my choice, going down the page along with the referenced item number.

Like this

Item #
5 Picture is Place here
26 Picture is Place here
42 Picture is Place here
1 Picture is Place here
456 Picture is Place here

Here is the Macro I have been using.
Sub InsertPicTest()
'
' Dim rw As Long
Dim itemnum As Long
Dim picsource As String

' Change value below to START ROW reference for update
' RW=X is the first row of data in list (IE ITEM)
rw = 4
' ColBase=X is the Column # of data for list (IE ITEM)
ColBase = 2
Do
' Change value below to REFERENCE COLUMN # (IE ITEM) reference for update
If ActiveSheet.Cells(rw, 2).Value = "" Then
Exit Do
End If

' Change value below to REFERENCE COLUMN #(IE ITEM) reference for update
itemnum = ActiveSheet.Cells(rw, 2).Value

' Change value below to REFERENCE COLUMN # for picture placement
ActiveSheet.Cells(rw, 9).Select


On Error Resume Next
ActiveSheet.Pictures.Insert(picsource).Select

On Error GoTo 0
rw = rw



' Change value below to REFERENCE COLUMN (IE ITEM) reference for update
itemnum = ActiveSheet.Cells(rw, 2).Value
' Change value below to REFERENCE COLUMN # for picture placement
ActiveSheet.Cells(rw, 9).Select

If Not InsertPicture2007("http://www.famousfootwear.com/productimages//FF_is" & Cells(rw, ColBase).Value & ".jpg", ActiveCell.Address) Then
If InsertPicture2007("http://www.famousfootwear.com/productimages/shoes_is" & Cells(rw, ColBase).Value & ".jpg", ActiveCell.Address) Then

End If
End If




On Error Resume Next
ActiveSheet.Pictures.Insert(picsource).Select

On Error GoTo 0
rw = rw + 1


Loop

Range("A4").Select

End Sub

Private Sub InsertPicture2003(sPicturePathAndFilename As String, sCellAddress As String)
On Error GoTo Reset_Cell
Dim oldHeight As Integer
Dim oldWidth As Integer
oldHeight = Range(sCellAddress).RowHeight
oldWidth = Range(sCellAddress).ColumnWidth
With Range(sCellAddress)
.RowHeight = 48
.ColumnWidth = 10
End With
With ActiveSheet.Pictures.Insert(sPicturePathAndFilename).ShapeRange
.Name = "Pic" & Range(sCellAddress).Offset(0, -1).Value
.LockAspectRatio = msoFalse
.PictureFormat.TransparentBackground = True
.PictureFormat.TransparencyColor = RGB(239, 239, 239)
.Width = 52
.Height = 48
End With
Exit_Insert:
On Error GoTo 0
Exit Sub
Reset_Cell:
ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Delete
With Range(sCellAddress)
.RowHeight = oldHeight
.ColumnWidth = oldWidth
End With
Resume Exit_Insert
End Sub

Private Function InsertPicture2007(sPicturePathAndFilename As String, sCellAddress As String) As Boolean
On Error GoTo Reset_Cell
Dim oldHeight As Integer
Dim oldWidth As Integer
oldHeight = Range(sCellAddress).RowHeight
oldWidth = Range(sCellAddress).ColumnWidth
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, Range(sCellAddress).Left, Range(sCellAddress).Top, 64, 64)
.Fill.UserPicture sPicturePathAndFilename
' .ShapeStyle = 0
End With

InsertPicture2007 = True
Exit_Insert:
On Error GoTo 0
Exit Function
Reset_Cell:
InsertPicture2007 = False
' ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Fill.UserPicture "http://product.brownshoeonline.com/images/noimage.gif"
' ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete
' With Range(sCellAddress)
' .RowHeight = oldHeight
' .ColumnWidth = oldWidth
' End With
Resume Exit_Insert
End Function




Now I am trying to do the same, but horizontally so the sheet can be copied into Powerpoint.

So would look like this (I am using Pic as a short for the inserted items picture)

PIC PIC PIC PIC PIC
5 26 42 1 456

Make Sense?

Then to have it repeat in "blocks" of data down the page (like every 8 rows or so.

Thanks again for looking.
Rob

I have seen that a few of you looked at my post....any ideas? or a point in the right direction?