Insert Pictures Into Cell With VBA

Bysystemroad

New Member
Joined
Jun 1, 2020
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Hello dear forum users

Since I cannot use the resources found about my problem, I ask you to find a solution to my problem.

I want to take the photos in the relevant folder, which corresponds to the product codes in column B, need to put pictures to column A with macro. At the same time, the pictures should take the cell size so that they do not overflow outside the cell.

Folder with photos: C: \ Users \ canberk.saka \ Desktop \ SS20 PHOTOS \ SS 2020 IMAGES \ SS20 FOTOS

Note: I do not know about macro. Therefore, I would appreciate if you can help in detail.

Please do not post previous topics. I can not revise the code in any way because people write macros according to their needs.

I will be very happy if you help.

Good Forums.
 

Attachments

  • WhatsApp Image 2020-06-01 at 17.02.59.jpeg
    WhatsApp Image 2020-06-01 at 17.02.59.jpeg
    246 KB · Views: 16

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
which corresponds to the product codes in column B

What is: "0Y1AA1402054550 WHITE" is the file name? what extension does jpg, gif or what?


Let's start with this, assuming that the above is the name of the file, which is in the mentioned folder and that its extension is jpg.

VBA Code:
Sub InsertPictures()
  Dim objPic As Picture, i As Long
  Dim sPath As String, sFile As String
  
  sPath = "C:\Users\canberk.saka\Desktop\SS20 PHOTOS\SS 2020 IMAGES\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If
  
  On Error Resume Next
  For Each objPic In ActiveSheet.Pictures
    If objPic.Name Like "img_*" Then
      objPic.Delete
    End If
  Next
  On Error GoTo 0
  
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
      Set objPic = ActiveSheet.Pictures.Insert(sPath & sFile)
      With Range("A" & i)
        objPic.ShapeRange.LockAspectRatio = msoFalse
        objPic.Top = .Top
        objPic.Left = .Left
        objPic.Width = .Width
        objPic.Height = .Height
        objPic.Name = "img_" & i
      End With
    End If
  Next
End Sub

_________________________________________________________________
NOTES:
1. If the mentioned folder does not exist, then the macro will stop and send this message:
"This directory does not exist"
So you must correct the name in the macro, if you cannot correct the name, then paste the correct name of your directory here and I modify the macro.

2. If the data in column B is the name of the file, but the file does not exist in the folder, then it will not insert any images.
So you check the name in the cell and correct it.

3. If the file extension is not jpg then tell me what is the file extension and I correct the macro.

4. HOW TO INSTALL MACROs
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (InsertPictures) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.
 
Upvote 0
Thanks for your help.

But there is no action when ı did your instructions.

My document name is : C:\Users\canberk.saka\Desktop\SS20 FOTOĞRAFLARI\SS 2020 IMAGES\SS20 FOTOS so ı changed in vba code too. U can see my vba code.

VBA Code:
Sub InsertPictures()
  Dim objPic As Picture, i As Long
  Dim sPath As String, sFile As String
  
  sPath = "C:\Users\canberk.saka\Desktop\SS20 FOTOĞRAFLARI\SS 2020 IMAGES\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If
  
  On Error Resume Next
  For Each objPic In ActiveSheet.Pictures
    If objPic.Name Like "img_*" Then
      objPic.Delete
    End If
  Next
  On Error GoTo 0
  
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
      Set objPic = ActiveSheet.Pictures.Insert(sPath & sFile)
      With Range("A" & i)
        objPic.ShapeRange.LockAspectRatio = msoFalse
        objPic.Top = .Top
        objPic.Left = .Left
        objPic.Width = .Width
        objPic.Height = .Height
        objPic.Name = "img_" & i
      End With
    End If
  Next
End Sub

You can see my excel document picture called "Ekran Alıntısı"

Also, you can see my product pictures called "Ekran Alıntısı1"

So ı think everything seems fine for the macro to work.

I need your help. Thank you so much
 

Attachments

  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    37.5 KB · Views: 14
  • Ekran Alıntısı 1 .JPG
    Ekran Alıntısı 1 .JPG
    59.8 KB · Views: 14
Upvote 0
Based on your image, the data starts at row 1.
So this line must have a 1:
For i = 1 To Range("B" & Rows.Count).End(3).Row

I also see in your image that the file name already has the extension, so in this line it is no longer necessary to put the extension, it should be like this:
sFile = Range("B" & i).Value
 
Upvote 0
Thank you so much now macro is working.

There is one more question
I added with macro all pictures but pictures are heavy. So documents going to be heavy too.
Normally ı can change "pictures size" ( you can see in the attached picture that from where ı change )

But with macro ı cant change all pictures size :(

Do you know some tricks about this situation?

I must do all pictures "HD Size"

Thanks for your attention.
 

Attachments

  • Ekran Alıntısı 3.JPG
    Ekran Alıntısı 3.JPG
    34 KB · Views: 4
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,293
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top