VBA for inserting multiple photos from a specified folder

S

SomeOrdinaryIndian

New Member
Joined
Jul 13, 2022
Messages
10
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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.
 

Attachments

  • Folder with pictures.jpg
    Folder with pictures.jpg
    153.5 KB · Views: 15
  • panormaic photos arrangement.jpg
    panormaic photos arrangement.jpg
    243.3 KB · Views: 14
  • panormaic photos arrangement 2.jpg
    panormaic photos arrangement 2.jpg
    232.8 KB · Views: 14
  • other photos arrangement.jpg
    other photos arrangement.jpg
    226.2 KB · Views: 13
Sort by date Sort by votes
SomeOrdinaryIndian said:
Could you add dialog prompt for saving the file
Click to expand...

Try this:

VBA Code: 
Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String, UserSaveFile 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 = msoTrue
        .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 = msoTrue
        .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
  With Application.FileDialog(msoFileDialogSaveAs)
    .AllowMultiSelect = False
    .Title = "Save file"
    .ButtonName = "Save"
    .InitialFileName = ThisWorkbook.Path
    If .Show <> 0 Then
      UserSaveFile = Trim(.SelectedItems(1))
      ActiveWorkbook.SaveAs UserSaveFile
    End If
  End With

  Application.ScreenUpdating = True
End Sub

🧙‍♂️
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
DanteAmor said:
Try this:

VBA Code: 
Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String, UserSaveFile 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 = msoTrue
        .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 = msoTrue
        .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
  With Application.FileDialog(msoFileDialogSaveAs)
    .AllowMultiSelect = False
    .Title = "Save file"
    .ButtonName = "Save"
    .InitialFileName = ThisWorkbook.Path
    If .Show <> 0 Then
      UserSaveFile = Trim(.SelectedItems(1))
      ActiveWorkbook.SaveAs UserSaveFile
    End If
  End With

  Application.ScreenUpdating = True
End Sub

🧙‍♂️
Click to expand...

Great and thank you very much!
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub Insert_photos()
  Dim sPath As String, sFile As String, sName As String, UserSaveFile 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 = msoTrue
        .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 = msoTrue
        .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
  With Application.FileDialog(msoFileDialogSaveAs)
    .AllowMultiSelect = False
    .Title = "Save file"
    .ButtonName = "Save"
    .InitialFileName = ThisWorkbook.Path
    If .Show <> 0 Then
      UserSaveFile = Trim(.SelectedItems(1))
      ActiveWorkbook.SaveAs UserSaveFile
    End If
  End With

  Application.ScreenUpdating = True
End Sub

🧙‍♂️
Click to expand...
Sorry for bothering you again! Just one more request with this
Could you write another macro for importing photos with names F1, F2, F3 etc., into the 3rd sheet(sheet name in screenshot) and arrange them in the same manner?

And kindly make some minor macro corrections for the sheet(Building and Tower Photos) to recognize and arrange photos in the order they're named. File name will be P1, P2, P3 etc.,

Thanks again!
 

Attachments

  • Screenshot 2024-08-09 021830.png
    Screenshot 2024-08-09 021830.png
    12 KB · Views: 3
Upvote 0
You must log in or register to reply here.

Similar threads

melodramatic
  • Question
Vba - insert photo with varying sizes
Replies
1
Views
488
Micron
M
T
  • Solved
VBA for inserting photos
Replies
5
Views
851
Georgiboy
Georgiboy
A
  • Solved
How can I exclude subfolders in a subfolder
Replies
5
Views
754
Ascherith
A
M
  • Question
VBA search for specific file name in folders and their subfolders
Replies
7
Views
2K
Candyman8019
C
S
  • Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
225
STARL0RD
S

Forum statistics

Threads
1,221,080
Messages
6,157,829
Members
451,442
Latest member
jennybell

Share this page

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