How to insert multiple images in an excel sheet based on adjoining column's value?

Well, I was facing this question but in my case the values were file names of images. I wanted to use the file names in column C to determine which files got inserted in column D.

Although, it may not be a perfect solution, it worked in my case. Also as I wasn't able to find the exact VBA code which worked for my specific case, I had to write one basis what I could find on the web.

Because I feel that this code will make things easy for a lot of people, I am sharing it here.

The code in bold has to be replaced by you but the bold code with a single apostrophe in the beginning is just a comment.

Module 1:

Sub imageinsertloop()

Dim mainWorkBook As Workbook

Set mainWorkBook = ActiveWorkbook

Sheets("WorkSheetName").Activate

Folderpath = "C:\Users\SampleUser\Desktop\Images"

Set fso = CreateObject("Scripting.FileSystemObject")

NoOfFiles = fso.GetFolder(Folderpath).Files.Count

Set listfiles = fso.GetFolder(Folderpath).Files

Dim counter As Integer

counter = 2

'tenthcounter = 11 in module 2

For Each fls In listfiles

  strCompFilePath = Folderpath & "\" & Trim(fls.Name)

  If strCompFilePath <> "" Then

    If InStr(1, strCompFilePath, Range("C" & counter).Value, vbTextCompare) > 1 Then

      Sheets("WorkSheetName").Range("D" & counter).ColumnWidth = 25

      Sheets("WorkSheetName").Range("D" & counter).RowHeight = 100

      Sheets("WorkSheetName").Range("D" & counter).Activate

      Call insert(strCompFilePath, counter)

      Sheets("WorkSheetName").Activate

      counter = counter + 1

    End If

  End If

Next

mainWorkBook.Save

End Sub

Function insert(PicPath, counter)

With ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoTrue, 0, 0, 50, 70)

.Left = ActiveSheet.Range("D" & counter).Left

.Top = ActiveSheet.Range("D" & counter).Top

.Placement = 1

End With

End Function

----------

Module 2:

Sub imageinsertloop()

Dim mainWorkBook As Workbook

Set mainWorkBook = ActiveWorkbook

Sheets("WorkSheetName").Activate

Folderpath = "C:\Users\SampleUser\Desktop\Images"

Set fso = CreateObject("Scripting.FileSystemObject")

NoOfFiles = fso.GetFolder(Folderpath).Files.Count

Set listfiles = fso.GetFolder(Folderpath).Files

Dim counter As Integer

counter = 11

'After counter equals 10 there is some unspecified error therefore seperate module

For Each fls In listfiles

  strCompFilePath = Folderpath & "\" & Trim(fls.Name)

  If strCompFilePath <> "" Then

    If InStr(1, strCompFilePath, Range("C" & counter).Value, vbTextCompare) > 1 Then

      Sheets("WorkSheetName").Range("D" & counter).ColumnWidth = 25

      Sheets("WorkSheetName").Range("D" & counter).RowHeight = 100

      Sheets("WorkSheetName").Range("D" & counter).Activate

      Call insert(strCompFilePath, counter)

      Sheets("WorkSheetName").Activate

      counter = counter + 1

    End If

  End If

Next

mainWorkBook.Save

End Sub

Function insert(PicPath, counter)

With ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoTrue, 0, 0, 50, 70)

.Left = ActiveSheet.Range("D" & counter).Left

.Top = ActiveSheet.Range("D" & counter).Top

.Placement = 1

End With

End Function

---------------------------------Code Ends----------------------------------------------------------------------------Additional Modules with different initial counters may be used as required----------------------You could also just change the counter and run the same module-----------------------

Note: Tested in Microsoft Office 365 in January 2021.

References:

1. https://www.mrexcel.com/board/threads/modifying-vba-script-to-add-pictures-to-excel.1104178/
2. https://www.automateexcel.com/vba/comment/
3. https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture
4. https://stackoverflow.com/questions/12936646/how-to-insert-a-picture-into-excel-at-a-specified-cell-position-with-vba
5. https://excel-macro.tutorialhorizon.com/excel-vba-insert-multiple-images-from-a-folder-to-excel-cells/