VBA for inserting multiple photos from a specified folder

[SomeOrdinaryIndian]

I know this has been asked many times here and in so many different ways before. Still unable to figure out a way to achieve this as per my needs.

So, I'm looking for a VBA code to insert multiple photos and arrange them in specific manner(not inside the cells) and resize with custom width size. Found a thread close to what I was looking for Macro to Insert and resize picture but couldn't figure out inserting multiple photos and arranging in the required specific manner as shown in the attached screenshot. The code should check the photo's name inside the folder and arrange them in the order, like 0, 30, 60, 90... so on inside the sheet.

And the other photos with file names Building Photo.jpg, Proposed Location.jpg etc., should go to a different sheet in the same workbook and also in the specified location as shown in the screenshot.

Hope you got what I'm asking for. Thanks.

 

[DanteAmor]

Before running the macro you must adjust the following:

1. The names of the sheets in this line:

  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")

2. If you want to set a height and width for all photos, put the values on these lines:

  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height

3. If you do not want to set a height and width and you want the height and width of each photo to remain, then you will have to delete these lines from the macro:

  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height
...
        .Width = nWid
        .Height = nHei
...
        .Width = nWid
        .Height = nHei

When you run the macro, you must select the folder where you have the photos.

Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, lr As Long, n As Long, m As Long
  Dim nLef1%, nTop1%, nLef2%, nTop2%, nMax1%, nMax2&
  Dim nHei%, nWid%
  
  'Fit with your data
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1)
  End With
  
  Application.ScreenUpdating = False
  sh1.DrawingObjects.Delete
  sh2.DrawingObjects.Delete
  sh1.Range("A:B").ClearContents
  sh1.Range("A:B").NumberFormat = "@"
  
  sFile = Dir(sPath & "\" & "*.jp*")
  
  Do While sFile <> ""
    i = i + 1
    sh1.Range("A" & i).Value = Split(sFile, ".")(0)
    sh1.Range("B" & i).Value = Split(sFile, ".")(1)
    sFile = Dir()
  Loop
  
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  sh1.Range("A1:B" & lr).Sort sh1.Range("A1"), _
    xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
  
  For i = 1 To lr
    sName = sPath & "\" & sh1.Range("A" & i).Value & "." & sh1.Range("B" & i).Value
    If IsNumeric(sh1.Range("A" & i).Value) Then
      With sh1.Pictures.Insert(sName)
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = nLef1
        .Top = nTop1
        .Width = nWid
        .Height = nHei
        nLef1 = nLef1 + .Width + 10
        If .Height > nMax1 Then nMax1 = .Height
        n = n + 1
        If n = 3 Then
          nTop1 = nTop1 + nMax1 + 10
          n = 0
          nLef1 = 0
        End If
      End With
    Else
      With sh2.Pictures.Insert(sName)
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = nLef2
        .Top = nTop2
        .Width = nWid
        .Height = nHei
        nLef2 = nLef2 + .Width + 10
        If .Height > nMax2 Then nMax2 = .Height
        m = m + 1
        If m = 3 Then
          nTop2 = nTop2 + nMax2 + 10
          m = 0
          nLef2 = 0
        End If
      End With
    End If
  Next
  sh1.Range("A:B").ClearContents

  Application.ScreenUpdating = True
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[SomeOrdinaryIndian]

Before running the macro you must adjust the following:

1. The names of the sheets in this line:

  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")

2. If you want to set a height and width for all photos, put the values on these lines:

  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height

3. If you do not want to set a height and width and you want the height and width of each photo to remain, then you will have to delete these lines from the macro:

  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height
...
        .Width = nWid
        .Height = nHei
...
        .Width = nWid
        .Height = nHei

When you run the macro, you must select the folder where you have the photos.

Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, lr As Long, n As Long, m As Long
  Dim nLef1%, nTop1%, nLef2%, nTop2%, nMax1%, nMax2&
  Dim nHei%, nWid%
 
  'Fit with your data
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height
 
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1)
  End With
 
  Application.ScreenUpdating = False
  sh1.DrawingObjects.Delete
  sh2.DrawingObjects.Delete
  sh1.Range("A:B").ClearContents
  sh1.Range("A:B").NumberFormat = "@"
 
  sFile = Dir(sPath & "\" & "*.jp*")
 
  Do While sFile <> ""
    i = i + 1
    sh1.Range("A" & i).Value = Split(sFile, ".")(0)
    sh1.Range("B" & i).Value = Split(sFile, ".")(1)
    sFile = Dir()
  Loop
 
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  sh1.Range("A1:B" & lr).Sort sh1.Range("A1"), _
    xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
 
  For i = 1 To lr
    sName = sPath & "\" & sh1.Range("A" & i).Value & "." & sh1.Range("B" & i).Value
    If IsNumeric(sh1.Range("A" & i).Value) Then
      With sh1.Pictures.Insert(sName)
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = nLef1
        .Top = nTop1
        .Width = nWid
        .Height = nHei
        nLef1 = nLef1 + .Width + 10
        If .Height > nMax1 Then nMax1 = .Height
        n = n + 1
        If n = 3 Then
          nTop1 = nTop1 + nMax1 + 10
          n = 0
          nLef1 = 0
        End If
      End With
    Else
      With sh2.Pictures.Insert(sName)
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = nLef2
        .Top = nTop2
        .Width = nWid
        .Height = nHei
        nLef2 = nLef2 + .Width + 10
        If .Height > nMax2 Then nMax2 = .Height
        m = m + 1
        If m = 3 Then
          nTop2 = nTop2 + nMax2 + 10
          m = 0
          nLef2 = 0
        End If
      End With
    End If
  Next
  sh1.Range("A:B").ClearContents

  Application.ScreenUpdating = True
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

Thank you for the code! This is just how I wanted it! Appreaciate it!

But I have issue with saving the file with the actual photos after adding them inside the sheets. How do I save the actual photos(it'll be around ~4mb) inside the workbook as xlsx and without the macros?

 

[DanteAmor]

How do I save the actual photos(it'll be around ~4mb) inside the workbook as xlsx and without the macros?

After this line:

  sh1.Range("A:B").ClearContents

Add these lines and adjust the file name:

  Sheets(Array(sh1.Name, sh2.Name)).Copy
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "File with photos.xlsx"

 

[SomeOrdinaryIndian]

After this line:

  sh1.Range("A:B").ClearContents

Add these lines and adjust the file name:

  Sheets(Array(sh1.Name, sh2.Name)).Copy
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "File with photos.xlsx"

Thanks. I believe its a code to save the file automatically after the macros is ran with and a desired name. The above code is handy and good to have at times.

But sorry for not being more clear. I need to save the whole workbook with the actual photos included in it after it has been imported and not like a symlink. The above code still saves the workbook(only ~12KB) with symlink of the photos directed to their original folder which is not how I intend to.

I have attached a screenshot showing how we manually insert pictures and then when we save the workbook the whole pictures are there inside the file without any symlink(the size depends on how many pictures are present inside the workbook and their size which would be around 3-5MB) ). Hope this clears it!
And Thanks again for your time!

 

[DanteAmor]

not like a symlink

I don't understand what you mean by that.

In my tests a new book is created as xlsx (without macros), with 2 sheets, the first sheet with photos arranged in ascending order of 3 by 3; and on the second page, with photos, where name is not a number. Just as you put it in your original post.

Found a thread close to what I was looking for Macro to Insert and resize picture

In that link, the line they use to insert images is this: Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

In my macro I use the same instruction: sh1.Pictures.Insert(sName)


Here is an example of the new book that the macro generates for me:

I'm afraid if it's not what you need, it wasn't clear from your original post. You did not put how you wanted the images on the sheet and you did not put that you wanted to save a file as xlsx.

 

[SomeOrdinaryIndian]

I don't understand what you mean by that.

In my tests a new book is created as xlsx (without macros), with 2 sheets, the first sheet with photos arranged in ascending order of 3 by 3; and on the second page, with photos, where name is not a number. Just as you put it in your original post.



In that link, the line they use to insert images is this: Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

In my macro I use the same instruction: sh1.Pictures.Insert(sName)


Here is an example of the new book that the macro generates for me:
View attachment 115049

I'm afraid if it's not what you need, it wasn't clear from your original post. You did not put how you wanted the images on the sheet and you did not put that you wanted to save a file as xlsx.

Yes. I didn't know how VBA code worked or handles pictures and saving them.

So, the saved file would be sent to someone and they won't be having the same pictures in the same directory and in the same name as mine.

Anyway thanks for your time!

 

[SomeOrdinaryIndian]

I don't understand what you mean by that.

In my tests a new book is created as xlsx (without macros), with 2 sheets, the first sheet with photos arranged in ascending order of 3 by 3; and on the second page, with photos, where name is not a number. Just as you put it in your original post.



In that link, the line they use to insert images is this: Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

In my macro I use the same instruction: sh1.Pictures.Insert(sName)


Here is an example of the new book that the macro generates for me:
View attachment 115049

I'm afraid if it's not what you need, it wasn't clear from your original post. You did not put how you wanted the images on the sheet and you did not put that you wanted to save a file as xlsx.

Your code is exactly what I need and does what I wanted. Its just that I'm looking a way to insert the images rather than linking them

 

[DanteAmor]

Try this:

Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, lr As Long, n As Long, m As Long
  Dim nLef1%, nTop1%, nLef2%, nTop2%, nMax1%, nMax2&
  Dim nHei%, nWid%
  
  'Fit with your data
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1)
  End With
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  sh1.DrawingObjects.Delete
  sh2.DrawingObjects.Delete
  sh1.Range("A:B").ClearContents
  sh1.Range("A:B").NumberFormat = "@"
  
  sFile = Dir(sPath & "\" & "*.jp*")
  
  Do While sFile <> ""
    i = i + 1
    sh1.Range("A" & i).Value = Split(sFile, ".")(0)
    sh1.Range("B" & i).Value = Split(sFile, ".")(1)
    sFile = Dir()
  Loop
  
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  sh1.Range("A1:B" & lr).Sort sh1.Range("A1"), _
    xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
  
  For i = 1 To lr
    sName = sPath & "\" & sh1.Range("A" & i).Value & "." & sh1.Range("B" & i).Value
    If IsNumeric(sh1.Range("A" & i).Value) Then

      With sh1.Shapes.AddPicture(sName, False, True, 1, 1, 1, 1)
        .LockAspectRatio = msoFalse
        .Left = nLef1
        .Top = nTop1
        .Width = nWid
        .Height = nHei
        nLef1 = nLef1 + .Width + 10
        If .Height > nMax1 Then nMax1 = .Height
        n = n + 1
        If n = 3 Then
          nTop1 = nTop1 + nMax1 + 10
          n = 0
          nLef1 = 0
        End If
      End With
    Else
      With sh2.Shapes.AddPicture(sName, False, True, 1, 1, 1, 1)
        .LockAspectRatio = msoFalse
        .Left = nLef2
        .Top = nTop2
        .Width = nWid
        .Height = nHei
        nLef2 = nLef2 + .Width + 10
        If .Height > nMax2 Then nMax2 = .Height
        m = m + 1
        If m = 3 Then
          nTop2 = nTop2 + nMax2 + 10
          m = 0
          nLef2 = 0
        End If
      End With
    End If
  Next
  sh1.Range("A:B").ClearContents
  
  Sheets(Array(sh1.Name, sh2.Name)).Copy
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "File with photos.xlsx"

  Application.ScreenUpdating = True
End Sub

 

[SomeOrdinaryIndian]

Try this:

Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, lr As Long, n As Long, m As Long
  Dim nLef1%, nTop1%, nLef2%, nTop2%, nMax1%, nMax2&
  Dim nHei%, nWid%
 
  'Fit with your data
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  nWid = 120                  'Fit Width
  nHei = 140                  'Fit Height
 
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    sPath = .SelectedItems(1)
  End With
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  sh1.DrawingObjects.Delete
  sh2.DrawingObjects.Delete
  sh1.Range("A:B").ClearContents
  sh1.Range("A:B").NumberFormat = "@"
 
  sFile = Dir(sPath & "\" & "*.jp*")
 
  Do While sFile <> ""
    i = i + 1
    sh1.Range("A" & i).Value = Split(sFile, ".")(0)
    sh1.Range("B" & i).Value = Split(sFile, ".")(1)
    sFile = Dir()
  Loop
 
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  sh1.Range("A1:B" & lr).Sort sh1.Range("A1"), _
    xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
 
  For i = 1 To lr
    sName = sPath & "\" & sh1.Range("A" & i).Value & "." & sh1.Range("B" & i).Value
    If IsNumeric(sh1.Range("A" & i).Value) Then

      With sh1.Shapes.AddPicture(sName, False, True, 1, 1, 1, 1)
        .LockAspectRatio = msoFalse
        .Left = nLef1
        .Top = nTop1
        .Width = nWid
        .Height = nHei
        nLef1 = nLef1 + .Width + 10
        If .Height > nMax1 Then nMax1 = .Height
        n = n + 1
        If n = 3 Then
          nTop1 = nTop1 + nMax1 + 10
          n = 0
          nLef1 = 0
        End If
      End With
    Else
      With sh2.Shapes.AddPicture(sName, False, True, 1, 1, 1, 1)
        .LockAspectRatio = msoFalse
        .Left = nLef2
        .Top = nTop2
        .Width = nWid
        .Height = nHei
        nLef2 = nLef2 + .Width + 10
        If .Height > nMax2 Then nMax2 = .Height
        m = m + 1
        If m = 3 Then
          nTop2 = nTop2 + nMax2 + 10
          m = 0
          nLef2 = 0
        End If
      End With
    End If
  Next
  sh1.Range("A:B").ClearContents
 
  Sheets(Array(sh1.Name, sh2.Name)).Copy
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "File with photos.xlsx"

  Application.ScreenUpdating = True
End Sub

Yep. This is it! Thanks!

A little request. Could you add dialog prompt for saving the file to the code instead of automatically saving it? And also add "lock aspect ratio" code to the pictures?