Excel/vloopkup VBA code

Advertisement


Question
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.

Answer
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
         SourcePicSheet.Pictures(PicName).Copy
         .Paste Destination:=.Cells(iRow, "B")
         .Cells(iRow, "B") = "Picture inserted"
        Else
         .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)
  Else
     Set Pic = Worksheets(EWSname).Shapes(P)
  End If
  PicExists = True
  Exit Function
NoPic:
  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.

Damon
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

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Damon Ostrander

Expertise

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.

Experience

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.

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

©2016 About.com. All rights reserved.