Macro to automatically search directory for a file name based of value in H1 and insert that photo in A11

[RcChrispy]

I have searched for a macro that can do this an have yet to find something that works the way I need it to. There are many similar macros but nothing that is a perfect match to my need. VBA noob here, any help is appreciated!

 

[ZVI]

Is this code you are looking for?

Sub InsertPicture()
 
  ' Select the destination cell
  Range("A11").Select
 
  ' Assuming that value "Daisy.jpg" is in cell H1 and the picture is in folder "C:\TEMP\"
  ' the below code inserts picture C:\TEMP\Daisy.jpg to the left top corner of the selected cell A11
  ActiveSheet.Pictures.Insert "C:\TEMP\" & Range("H1").Value
 
End Sub

Just replace "C:\TEMP\" by your folder path

 

[RcChrispy]

Thanks for your response! I attempted to use this code and changed the file path to the correct location and received this message:

runtime error '1004'
insert method of pictures class failed

 

[ZVI]

Try this test version to find the reason of the problem:

Sub InsertPicture_TestVersion()
 
  ' --> Settings, change to suit
  Const Folder = "C:\TEMP\"     ' Folder with picture
  Const CellWithFilename = "H1" ' Cell with filename
  Const DestinationCell = "A11" ' Cell to insert the picture
  ' <-- End of settings
 
  Dim f As String, PathSep As String
 
  ' Apply correct path separator
  PathSep = Application.PathSeparator
  f = Replace(Folder, "\", PathSep)
  If Right(f, 1) <> PathSep Then f = f & PathSep
 
  ' Check the folder
  If Dir(f, vbDirectory) = "" Then
    MsgBox "Folder not found:" & vbLf & f, vbCritical, "Error1"
    Exit Sub
  End If
 
  ' Check file extension
  If InStr(Range(CellWithFilename).Value, ".") = 0 Then
    Range(CellWithFilename).Select
    MsgBox "File extension not found in " & CellWithFilename, vbCritical, "Error2"
    Exit Sub
  End If
 
  ' Check the file
  f = f & Trim(Range(CellWithFilename).Value)
  If Dir(f) = "" Then
    MsgBox "File not found:" & vbLf & f, vbCritical, "Error3"
    Exit Sub
  End If
 
  ' Check sheet protection
  If ActiveSheet.ProtectContents Then
    MsgBox "Unprotect the sheet, please", vbCritical, "Error4"
    Exit Sub
  End If
 
  ' Select the destination cell
  Range(DestinationCell).Select
  
  ' Insert the picture
  On Error Resume Next
  ActiveSheet.Pictures.Insert f
  If Err Then
    MsgBox Err.Description, vbCritical, "Error#" & Err.Number
  End If
 
End Sub

Let me know please what version of Excel is used.

 

[ZVI]

If the above code does not help then you can do as follows:
1. Activate the [Developer] tab: tab [File] – Options - Customize Ribbon - under Customize the Ribbon and under Main Tabs select the Developer check box.
2. Turn on the macro-recorder: tab [Developer] – Record Macro
3. Manually insert the picture: tab [Insert] – Picture
4. Tab [Developer] - Stop Recording
5. Press Alt-F11 to check correct path and file name in the recorder macro.
For further assistance please post that recorded macro here.

 

[RcChrispy]

So I ran the test version and the picture was inserted. however, I still receive an error message when running the original code. Here is a link to an imgur album I just uploaded.

Imgur: The most awesome images on the Internet

The first image shows the error when running the original code.
The second shows a comparison of the original and test versions.
The third shows the result of running the test version.

The goal would be to have the image formatted to the size of the Cell (being A11), as well.

Again, I really appreciate your help. I am developing a cookie cutter system that can be used for projects in the future. There are hundreds of forms and hundreds of pictures to insert all with different names.

Thank you.

 

[RcChrispy]

Excel 2013

 

[ZVI]

According to your 2nd screenshot the rightmost backslash symbol was missed in the path.
Find it in my 1st code: ActiveSheet.Pictures.Insert "C:\TEMP\" & Range("H1").Value

The 2nd version of the code is more safety and automatically corrects such a problem by this line of the code:
If Right(f, 1) <> PathSep Then f = f & PathSep
This version also uses application path symbol.

Below is the 3d version of the code where size of the inserted picture is the same as the size of destination cell A11.

Sub InsertPicture3()
 
  ' --> Settings, change to suit
  Const Folder = "C:\TEMP\"     ' Folder with picture
  Const CellWithFilename = "H1" ' Cell with filename
  Const DestinationCell = "A11" ' Cell to insert the picture
  ' <-- end of settings
 
  Dim f As String, PathSep As String
 
  ' Apply correct path separator
  PathSep = Application.PathSeparator
  f = Replace(Folder, "\", PathSep)
 
  ' Add backslash if it was missed
  If Right(f, 1) <> PathSep Then f = f & PathSep
 
  ' Check the folder
  If Dir(f, vbDirectory) = "" Then
    MsgBox "Folder not found:" & vbLf & f, vbCritical, "Error1"
    Exit Sub
  End If
 
  ' Check file extension
  If InStr(Range(CellWithFilename).Value, ".") = 0 Then
    Range(CellWithFilename).Select
    MsgBox "File extension not found in " & CellWithFilename, vbCritical, "Error2"
    Exit Sub
  End If
 
  ' Check the file
  f = f & Trim(Range(CellWithFilename).Value)
  If Dir(f) = "" Then
    MsgBox "File not found:" & vbLf & f, vbCritical, "Error3"
    Exit Sub
  End If
 
  ' Check sheet protection
  If ActiveSheet.ProtectContents Then
    MsgBox "Unprotect the sheet, please", vbCritical, "Error4"
    Exit Sub
  End If
 
  ' Select the destination cell
  Range(DestinationCell).Select
 
  ' Insert the picture and resize it
  On Error Resume Next
  With ActiveSheet.Pictures.Insert(f)
    .ShapeRange.LockAspectRatio = msoFalse
    .Placement = xlMoveAndSize
    .Width = Range(DestinationCell).Width
    .Height = Range(DestinationCell).Height
  End With
  If Err Then
    MsgBox Err.Description, vbCritical, "Error#" & Err.Number
  End If
 
End Sub

Hope it works now as expected.