Importing images from folders into corresponding cells in the worksheet

[DyG]

Hello.
I need a macro that I have no idea how to even start making.

I have multiple images in multiple subfolders. The file structure looks like this:

/Excel_file.xlsm​

/Images/Object1/Image1-1.jpg​

/Images/Object1/Image1-2.jpg​

[...]​

/Images/Object2/Image2-1.jpg​

/Images/Object2/Image2-2.jpg​

[...]​

etc.​

I need a macro that will scan the 'Images' folder with all subfolders to find all images (all are .jpg) and will insert them into worksheet in the cell with the same value as the name of the .jpg.

• All the images have individual names. All the values in the cells are also individual.
• There are more cells with those values than images. Not every cell gets an image, but every image has a corresponding cell.
• Cells locations vary across the whole worksheet, there is not much constant about the addresses of those cells (only the range of few columns is constant) so the macro has to also find the cell address.
• No need to worry about image size and position. All I need is for it to be pasted in a cell.

Thank you in advance for any help.

 

[John_w]

Assuming all the cell values are the file name without the .jpg extension, e.g. Image1-1, try this macro:

Public Sub Add_Images_To_Cells()

    Dim folderPath As String
    Dim filesDict As Object 'Scripting.Dictionary
    Dim cell As Range
    Dim picShape As Shape
    
    folderPath = ThisWorkbook.Path & "\Images\"
    
    Set filesDict = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
    Create_Files_Dictionary folderPath, filesDict
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        For Each cell In .Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants)
            If filesDict.Exists(cell.Value) Then
                Set picShape = .Shapes.AddPicture(fileName:=filesDict(cell.Value), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                  Left:=cell.Left, Top:=cell.Top, Width:=-1, Height:=-1)
                picShape.Name = cell.Value
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub


Private Sub Create_Files_Dictionary(ByVal startFolder As String, filesDict As Object)

    Dim WSh As Object 'WshShell
    Dim command As String
    Dim allFiles As Variant
    Dim i As Long, p1 As Long, p2 As Long
    
    If Right(startFolder, 1) <> "\" Then startFolder = startFolder & "\"
    command = "cmd /c DIR /S /B " & Chr(34) & startFolder & "*.jpg" & Chr(34)
    Set WSh = CreateObject("WScript.Shell") 'New WshShell
    allFiles = Split(WSh.Exec(command).StdOut.ReadAll, vbCrLf)
    
    For i = 0 To UBound(allFiles) - 1
        p1 = InStrRev(allFiles(i), "\")
        p2 = InStrRev(allFiles(i), ".")
        filesDict.Add Mid(allFiles(i), p1 + 1, p2 - p1 - 1), allFiles(i)
    Next
    
End Sub

The code should be quite fast because it scans the /Images/ subfolder tree only once and looks at only the populated cells on the active sheet.

 

[DyG]

Assuming all the cell values are the file name without the .jpg extension, e.g. Image1-1, try this macro:

Public Sub Add_Images_To_Cells()

    Dim folderPath As String
    Dim filesDict As Object 'Scripting.Dictionary
    Dim cell As Range
    Dim picShape As Shape
   
    folderPath = ThisWorkbook.Path & "\Images\"
   
    Set filesDict = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
    Create_Files_Dictionary folderPath, filesDict
   
    Application.ScreenUpdating = False
   
    With ActiveSheet
        For Each cell In .Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants)
            If filesDict.Exists(cell.Value) Then
                Set picShape = .Shapes.AddPicture(fileName:=filesDict(cell.Value), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                  Left:=cell.Left, Top:=cell.Top, Width:=-1, Height:=-1)
                picShape.Name = cell.Value
            End If
        Next
    End With
   
    Application.ScreenUpdating = True
   
    MsgBox "Done"
   
End Sub


Private Sub Create_Files_Dictionary(ByVal startFolder As String, filesDict As Object)

    Dim WSh As Object 'WshShell
    Dim command As String
    Dim allFiles As Variant
    Dim i As Long, p1 As Long, p2 As Long
   
    If Right(startFolder, 1) <> "\" Then startFolder = startFolder & "\"
    command = "cmd /c DIR /S /B " & Chr(34) & startFolder & "*.jpg" & Chr(34)
    Set WSh = CreateObject("WScript.Shell") 'New WshShell
    allFiles = Split(WSh.Exec(command).StdOut.ReadAll, vbCrLf)
   
    For i = 0 To UBound(allFiles) - 1
        p1 = InStrRev(allFiles(i), "\")
        p2 = InStrRev(allFiles(i), ".")
        filesDict.Add Mid(allFiles(i), p1 + 1, p2 - p1 - 1), allFiles(i)
    Next
   
End Sub

The code should be quite fast because it scans the /Images/ subfolder tree only once and looks at only the populated cells on the active sheet.

It worked flawlessly. And like you said, it's quite fast. Also the code is so elegant
Thank you so much!

For the record I will just add my other idea.
I was also working right now on an approach that would be using the HYPERLINK() function to modify worksheet, so I could still have just the name displayed in the cell, but there would be a function inside generating the address, which in my case would be quite easy. With those hyperlinks the macro could just search for them and insert linked images. However I couldn't make this work either.

 

[John_w]

For the record I will just add my other idea.
I was also working right now on an approach that would be using the HYPERLINK() function to modify worksheet, so I could still have just the name displayed in the cell, but there would be a function inside generating the address, which in my case would be quite easy. With those hyperlinks the macro could just search for them and insert linked images. However I couldn't make this work either.

To have the code look at the cell's value which is the 'friendly_name' argument of the HYPERLINK function, instead of a text value, simply change SpecialCells(xlCellTypeConstants) to SpecialCells(xlCellTypeFormulas).

 

[DyG]

Hello. Sorry for a little out of topic question but I encountered a software problem with Excel and I'm out of ideas.
I was messing with some macros today. Some of them were causing Excel to crash (unintended infinite loops), so I was closing it with the Task Manager and for some reason your macro doesn't work anymore. I'm not even sure if this is related.
Anyway,other macros (more basic) work fine. I tried rebooting everything, creating new clean files, checked if Microsoft Scripting Runtime is enabled, even reinstalled Excel and some other Microsoft tools, but without success.
Your macro still runs to the end of code without any errors, except the images just don't appear in the worksheet.
Do you have any ideas what could be causing my issue?

 

[John_w]

Your macro still runs to the end of code without any errors, except the images just don't appear in the worksheet.
Do you have any ideas what could be causing my issue?

I don't know why this happens. Remember, it is looking at cells in the active sheet. Just for debugging to see what files it finds, change

command = "cmd /c DIR /S /B " & Chr(34) & startFolder & "*.jpg" & Chr(34)

to:

command = "cmd /k DIR /S /B " & Chr(34) & startFolder & "*.jpg" & Chr(34)

and:

allFiles = Split(WSh.Exec(command).StdOut.ReadAll, vbCrLf)

to:

    WSh.Run command, 1
    Stop

The code should now display a command window showing the *.jpg files found in the main folder and its subfolders.

 

[DyG]

Hi. After quite some trial and error I've managed to figure out what is causing the issue. The cause is quite specific and beyond my understanding.
Turns out that your macro is very sensitive about contents of cells A2; B1 and B2.

1. When cells A2; B1 and B2 are empty, everything works fine.
2. When one of the cells A2; B1 and B2 has a constant then:
   • The macro breaks when using

     SpecialCells(xlCellTypeFormulas)

     (on this specific line)
   • The macro doesn't break, but no images are imported when using

     SpecialCells(xlCellTypeConstants)

3. When one of the cells A2; B1 and B2 has a formula then:
   • The macro doesn't break, but no images are imported when using

     SpecialCells(xlCellTypeFormulas)

   • The macro breaks when using

     SpecialCells(xlCellTypeConstants)

     (on this specific line)

I'm baffled, to say the least.

 

[DyG]

Also for the record. When playing with some modifications of this macro, and also while using your debugging lines, Microsoft sometimes panics that it's some virus. This was also part of my problem, but quite obvious one, because there were pop-up notifications.
I had plenty of 'Malicious macros were found' alerts after which Excel turns off as well as Windows Defender blocking the xlms file and marking it as Trojan.
I had to mark the file as trusted in Windows Defender and also in Excel Trust Center Settings: Add, remove, or change a trusted location

 

[John_w]

Change:

        For Each cell In .Range("A1").CurrentRegion.SpecialCells(xlCellTypeFormulas))

to:

        For Each cell In .UsedRange.SpecialCells(xlCellTypeFormulas)