promjena slike prema zadanom kriteriju

Code:
Sub Image()
Worksheets("print").DrawingObjects.Delete

Dim picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

    lThisRow = 9
      
    Do While (Cells(lThisRow, 6) <> "")
      
      
        pasteAt = lThisRow
        Cells(pasteAt, 1).Select 'This is where picture will be inserted
          
          
        picname = Cells(lThisRow, 6) 'This is the picture name
          
        present = Dir("C:\Pictures\" & picname & ".jpg")
          
        If present <> "" Then
              
            ActiveSheet.Pictures.Insert("C:\Pictures\" & picname & ".jpg").Select 'Path to where pictures are stored
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' This resizes the picture
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            With Selection
            '.Left = Range("A6").Left
            '.Top = Range("A6").Top
            .Left = Cells(pasteAt - 1, 7).Left
            .Top = Cells(pasteAt - 1, 7).Top
              
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 32#
            .ShapeRange.Width = 32#
            .ShapeRange.Rotation = 0#
            End With
          
  

        Else
            Cells(pasteAt, 7) = "No Picture Found"
        End If
          
           lThisRow = lThisRow + 3
    Loop
      
    Range("A10").Select
    Application.ScreenUpdating = True
      
    Exit Sub
      
ErrNoPhoto:
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
    Range("B20").Select

End Sub