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: 20
  • panormaic photos arrangement.jpg
    panormaic photos arrangement.jpg
    243.3 KB · Views: 18
  • panormaic photos arrangement 2.jpg
    panormaic photos arrangement 2.jpg
    232.8 KB · Views: 16
  • other photos arrangement.jpg
    other photos arrangement.jpg
    226.2 KB · Views: 17
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

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
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: 5
Upvote 0
You must log in or register to reply here.

Similar threads

Q
  • Question Question
Import multiple photos from folders in columns
Replies
2
Views
229
Qba
Q
melodramatic
  • Question Question
Vba - insert photo with varying sizes
Replies
1
Views
574
Micron
M
T
  • Solved
VBA for inserting photos
Replies
5
Views
912
Georgiboy
Georgiboy
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
A
  • Solved
How can I exclude subfolders in a subfolder
Replies
5
Views
995
Ascherith
A

Forum statistics

Threads
1,224,818
Messages
6,181,152
Members
453,021
Latest member
Justyna P

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