Excel/vloopkup VBA code


I have a list of part numbers in sheet 1 column A and corresponding photos for each part number in column F. Now I have a list of part numbers in sheet 2 and I want to apply Vlookup funtion in sheet2 and if that part number exist in sheet 2 photo of that part should come in sheet 2 column B. Please help me by telling how can I do this.

Hello Saurabh,

Here is the solution I promised yesterday.  The way it gets around the VLOOKUP is by naming each picture a name with the part number embedded in it, in this case simply a string that is the serial number with "P_" prefixed.  Because it directly references each picture it should be very fast no matter how many part numbers and pictures you have.

In order to name the pictures, which could be a tedious process manually (especially if you have a really lot of them) I wrote a macro to do this for you.  The macro is FindRenamePics and it has a helper function PicInCell. Paste this macro code in a standard macro module of your workbook.

Sub FindRenamePics()
  'loops through part numbers in column A and renames any picture it finds
  'in the same row of column F with the part number prefixed with "P_".
  Dim P       As Shape    'a picture
  Dim iRow    As Long
  For iRow = 1 To Range("A65536").End(xlUp).Row
     'now loop through all pictures to see if any reside in column F of iRow
     For Each P In ActiveSheet.Shapes
        If PicInCell(P, Cells(iRow, "F")) Then
         P.Name = "P_" & Cells(iRow, "A").Text
        End If
     Next P
  Next iRow
End Sub

Function PicInCell(P As Shape, C As Range) As Boolean

  'Yields TRUE if picture P resides in cell C

  PicInCell = False
  If P.Top < C.Top Then Exit Function
  If P.Top > C.Top + C.Height Then Exit Function
  If P.Left < C.Left Then Exit Function
  If P.Left > C.Left + C.Width Then Exit Function
  PicInCell = True
End Function

Activate Sheet1, then run FindRenamePics. This should properly name all the pictures.  To verify a picture name simply select the picture and view the name in the Name box just above cell A1.

If you find a picture hasn't been renamed by this macro it is because the picture doesn't actually reside in the appropriate row in column F or isn't actually in column F.  The picture must reside "in" the cell, which means its top left corner must lie within or on the boundary of the cell.  Even one pixel outside will cause the routine to consider it to lie in a different cell, and fail to name it.  If you get an error it is probably because two pictures lie in the same cell due to this issue, and is trying to give two pictures the same name, which it can't.

Okay, now you are ready to use the lookup code.  Also paste this code in a standard macro module (can add it to the same module as before):

Sub PastePics()

  'Reads part numbers in Sheet1 col A, and gets corresponding picture for each in
  'Sheet2 (if picture exists) and pastes it in column B next to part number cell.
  'Note: does not size picture to fit in cell, nor expand cell to fit picture.
  'Picture will be placed with its top left corner at top left corner of cell.
  Dim iRow          As Long
  Dim PartNo          As String
  Dim PicName          As String
  Dim NewPicName       As String
  Dim DestPicSheet     As Worksheet
  Dim SourcePicSheet   As Worksheet
  Set SourcePicSheet = Worksheets("Sheet1")
  Set DestPicSheet = Worksheets("Sheet2")
  With DestPicSheet
     For iRow = 1 To .Range("A65536").End(xlUp).Row
        PartNo = .Cells(iRow, "A").Text
        PicName = "P_" & PartNo
        If PicExists(PicName, SourcePicSheet.Name) Then
         .Paste Destination:=.Cells(iRow, "B")
         .Cells(iRow, "B") = "Picture inserted"
         .Cells(iRow, "B") = "No picture"
        End If
     Next iRow
  End With
End Sub

Function PicExists(P As String, Optional EWSname As Variant) As Boolean
  'Return true if P references an existing shape embedded in worksheet EWS
  Dim Pic     As Shape
  On Error GoTo NoPic
  If IsMissing(EWSname) Then
     Set Pic = ActiveSheet.Shapes(P)
     Set Pic = Worksheets(EWSname).Shapes(P)
  End If
  PicExists = True
  Exit Function
  PicExists = False
End Function

Again there is a helper function PicExists.

Simply run the macro PastePics to insert all the pictures in column B next to the corresponding part numbers in column A.

Some caveats:

I have assumed the pictures are already sized appropriately to fit in the cells.  If not code would need to be added to either resize the pictures, or resize the width of column B or the row heights in Sheet2 to correspond to the picture width and height.

I have assumed your part numbers are no more than 38 characters long, and contain no punctuation or spaces.  If this assumption is not correct the code will need to be modified.

I have not incorporated any error handling to make the routines "bulletproof". Hopefully, if you encounter any problems that require adding error handling you can see how to incorporate it yourself, but if not feel free to follow up.

Good luck.  Let me know if you have any problems, and

Keep Excelling.

About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here


All Answers

Answers by Expert:

Ask Experts


Damon Ostrander


I have extensive experience with VBA programming in Excel 5 through Excel 2013. As a former aerospace engineer with a large aerospace corporation and consultant in a small defense technology services company, I have developed a wide range of applications in VBA, including simulations involving mixed-language programming, satellite orbit mechanics, graphics and animation, and real-time applications. I am interested in moderate to hard VBA-related questions only.


I have developed and taught several courses in Excel VBA programming and also VBA programming in Office 97, 2000, and 2007. I have developed a number of large technical applications in Excel VBA for use within the aerospace industry.

B.S. in Electrical Engineering and Computer Science, University of California, Berkeley.

©2017 About.com. All rights reserved.

[an error occurred while processing this directive]