Import multiple photos from folders in columns

[Qba]

Hi,
I'm working on some code to import multiple images into one sheet and I stumble to modify the code from 2022 thread (import multiple photos from a folders then resize) to change it's behavior slightly.

The code:

Public Sub insertpics()

    Dim folders() As String, foldersCount As Long
    Dim showOK As Boolean
    Dim fileName As String
    Dim i As Long
    Dim pic As Shape
    Dim picRange As Range
    Dim xSht As Worksheet
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        foldersCount = 0
        Do
            .Title = "Select images folder " & foldersCount + 1 & " or click Cancel to " & IIf(foldersCount = 0, "exit macro", "insert images")
            showOK = .Show
            If showOK Then
                ReDim Preserve folders(0 To foldersCount)
                folders(foldersCount) = .SelectedItems(1) & "\"
                foldersCount = foldersCount + 1
            End If
        Loop Until Not showOK
    End With
    If foldersCount = 0 Then Exit Sub
    
    
    Set xSht = ThisWorkbook.Worksheets("agrE")
    Set picRange = xSht.Range("B12")
    
    For i = 0 To UBound(folders)
        fileName = Dir(folders(i) & "*.*")
        While fileName <> vbNullString
            If InStr(1, "|.jpg|.png.|.bmp|", "|" & Mid(fileName, InStrRev(fileName, ".")) & "|", vbTextCompare) Then
                With picRange
                    Set pic = .Worksheet.Shapes.AddPicture(fileName:=folders(i) & fileName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                           Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
                    Set picRange = .Offset(, .Columns.Count)
                End With
            End If
            fileName = Dir
        Wend
    Next
    
End Sub

I would like and frankly I need the code to import the pictures from one folder in rows begining at B12 and then the next folder should populate rows from C12 and so on.
Basically every folder in seperate columns.

How can I modify the code to accomplish this?

 

[DanteAmor]

Hi and welcome to MrExcel

Try:

Public Sub insertpics()
  Dim folders() As String, foldersCount As Long
  Dim i As Long, j As Long, k As Long
  Dim fileName As String
  Dim xSht As Worksheet
  Dim showOK As Boolean
  Dim pic As Shape
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    foldersCount = 0
    Do
      .Title = "Select images folder " & foldersCount + 1 & " or click Cancel to " & IIf(foldersCount = 0, "exit macro", "insert images")
      showOK = .Show
      If showOK Then
        ReDim Preserve folders(0 To foldersCount)
        folders(foldersCount) = .SelectedItems(1) & "\"
        foldersCount = foldersCount + 1
      End If
    Loop Until Not showOK
  End With
  If foldersCount = 0 Then Exit Sub
  
  Set xSht = ThisWorkbook.Worksheets("agrE")
  k = 12
  j = 2
  
  For i = 0 To UBound(folders)
    fileName = Dir(folders(i) & "*.*")
    While fileName <> vbNullString
      If InStr(1, "|.jpg|.png.|.bmp|", "|" & Mid(fileName, InStrRev(fileName, ".")) & "|", vbTextCompare) Then
        With xSht.Cells(k, j)
          Set pic = .Worksheet.Shapes.AddPicture(fileName:=folders(i) & fileName, LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
          k = k + 1
        End With
      End If
      fileName = Dir
    Wend
    k = 12
    j = j + 1
  Next
End Sub

 

[Qba]

Hi,
thank you. Your reply was so fast but I won't be able to test changes till monday when I'm back in the office. I will definetely reply with some feedback then.

Meanwhile thank you for you help and enjoy the weekend.