Using VBA to pull images from folder to sheet

[linkjg]

Hello,

I have a folder on my desktop with about 400 jpgs. The images are labeled with numerals like "1.jpg" "2.jpg" "3.jpg" etc.

Is there a VBA function that would extract the file name and pictures and put them into an Excel worksheet? Could the cell with the picture be formatted to fit within the cell?

Example of output

A1: Name / B1: Picture
A2: 1 B2: Image of 1.jpg
A3: 2 B3: Image of 2.jpg
A4: 3 B4: Image of 3.jpg

Thank you for your help!

 

[yky]

Try this:

Sub insert_pictures()
    
    Const factor = 0.9  'picture is 90% of the size of cell

    'Variable Declaration
    Dim fsoLibrary As FileSystemObject
    Dim fsoFolder As Object
    Dim sFolderPath As String
    Dim sFileName As Object
    Dim p As Object

    Dim i As Long   'counter
    Dim last_row As Long
    Dim ws As Worksheet

        sFolderPath = "C:\Users\me\Desktop"  'may need to change this line to suit your situation

    
    'Set all the references to the FSO Library
    Set fsoLibrary = CreateObject("Scripting.FileSystemObject")
    Set fsoFolder = fsoLibrary.GetFolder(sFolderPath)
    Set ws = ThisWorkbook.Sheets("Sheet1")
    On Error Resume Next
    
    With ws
        .Range("A1") = "Name"
        .Range("B1") = "Picture"
    
        'Loop through each file in a folder
        i = 2
        For Each sFileName In fsoFolder.Files
            .Cells(i, 1) = Left(sFileName.Name, InStr(sFileName.Name, ".") - 1)
            i = i + 1
            '        Debug.Print sFileName.Name
        Next sFileName
        
        last_row = i
        
        Range(.Cells(2, 1), .Cells(i, 1)).Sort key1:=.Cells(2, 1), order1:=xlDescending
    
        For i = 2 To last_row Step 1
    
            Set p = .Shapes.AddPicture(Filename:=sFolderPath _
                & Cells(i, 1).Value & ".jpg", LinkToFile:=False, SaveWithDocument:=True, _
                Left:=.Cells(i, 2).Left, Top:=Cells(i, 2).Top, Width:=-1, Height:=-1)

            p.Width = .Cells(i, 2).Width * factor
            'adjust row height
            If .Cells(i, 2).RowHeight < p.Height / factor Then
                .Cells(i, 2).RowHeight = p.Height / factor
            End If

            p.Left = .Cells(i, 2).Left + (.Cells(i, 2).Width - p.Width) / 2
            p.Top = .Cells(i, 2).Top + (.Cells(i, 2).Height - p.Height) / 2
            Next i
        End With
    
    'Release the memory
    Set fsoLibrary = Nothing
    Set fsoFolder = Nothing

End Sub

 

[linkjg]

Thank you for your help! When I insert the code and run it, I am getting a "user-defined type not defined" error. I am using Excel 2007. Is there a way I can fix?

 

[yky]

Not sure about Excel 2007. In 2010, I went to Developer/Visual Basic, then Tools/References... and added Microsoft Scripting Runtime library.

 

[linkjg]

Thank you! Worked perfectly after selecting the Microsoft Scripting Runtime library. Thanks so much!

 

[yky]

Glad to be able to help and thanks for the feedback.

 

[kefier]

Hey, thank you very much for the code. But i am getting the error "An error occured while importing this file: C\Uers\ksh\Desktop.jpg". I figured out that changing the parameter SaveWithDocument:=True to SaveWithDocument:=False makes Vba getting rid of the error, but then nothing happens. Do you maybe know how to solve this problem?

Greetings,

kefier