Excel incorrectly placing images

Question

I'm trying to help out a coworker with her VBA in Excel 2013. It looks like the macro is successfully pulling in the images from the designated path, but it dumps every single photo into cell A1.

Any thoughts?

Sub DeleteAllPictures()
   Dim S As Shape
   For Each S In ActiveSheet.Shapes
     Select Case S.Type
       Case msoLinkedPicture, msoPicture
         S.Delete
     End Select
   Next
 End Sub

Sub UpdatePictures()
   Dim R As Range
   Dim S As Shape
   Dim Path As String, FName As String

  'Setup the path
   Path = "G:\In Transit\Carlos\BC Website images"
   'You can read this value also from a cell, e.g.:
   'Path = Worksheets("Setup").Range("B1")

  'Be sure the path has a trailing backslash
   If Right(Path, 1) <> "\" Then Path = Path & "\"

  'Visit each used cell in column A
   For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
     'Try to get the shape
     Set S = GetShapeByName(R)
     'Found?
     If S Is Nothing Then
       'Find the picture e.g. "C:\temp\F500.*"
       FName = Dir(Path & R & ".*")
       'Found?
       If FName <> "" Then
         Set S = InsertPicturePrim(Path & FName, R)
       End If
     End If
     If Not S Is Nothing Then
       'Show the error if the name did not match the cell
       If S.Name <> R Then R.Interior.Color = vbRed
       With R.Offset(0, 1)
         'Move the picture to the cell on the right side
         S.Top = .Top
         S.Left = .Left
         'Resize it
         S.Width = .Width

        'Remove the aspect ratio by default if necessary
         'S.LockAspectRatio = False

        If S.LockAspectRatio Then
           'Make it smaller to fit the cell if necessary
           If S.Height > .Height Then S.Height = .Height
         Else
           'Stretch the picture
           S.Height = .Height
         End If
       End With
       'Move it behind anything else
       S.ZOrder msoSendToBack
     Else
       R.Offset(0, 1) = "No picture available"
     End If
   Next
 End Sub

Private Function GetShapeByName(ByVal SName As String) As Shape
   'Return the shape with SName, Nothing if not exists
   On Error Resume Next
   Set GetShapeByName = ActiveSheet.Shapes(SName)
 End Function

Private Function InsertPicturePrim(ByVal FName As String, ByVal SName As String) As Shape
   'Inserts the picture, return the shape, Nothing if failed
   Dim P As Picture
   On Error Resume Next
   'Insert the picture
   Set P = ActiveSheet.Pictures.Insert(FName)
   'code to resize
    With P
    .ShapeRange.LockAspectRatio = msoFalse
    .Height = ActiveCell.Height
    .Width = ActiveCell.Width
    .Top = ActiveCell.Top
    .Left = ActiveCell.Left
    .Placement = xlMoveAndSize
   End With
   Set P = Nothing

'code to resize

   'Success?
   If Not P Is Nothing Then
     'Return the shape
     Set InsertPicturePrim = P.ShapeRange(1)
     'Rename it, so we can easily find it later
     P.Name = SName
   End If
 End Function

Answer 1

The short answer is: your macro is inserting the picture at the selected cell. Change the selection before the insert line, and you should get it inserted at each row.

Here in this example, I am selecting the cell to the left of the cell you are pulling the name value from.

   If FName <> "" Then
     'select the cell 1 to the left of the cell containing the image name
     R.Offset(0,-1).select
     Set S = InsertPicturePrim(Path & FName, R)
   End If