VBA Extract Photos From A Folder in Couple Cell (Couple Photo)

[muhammad susanto]

hi expert..
i have macro code to extract photo from a folder..the code actually working well in a single cell down.
i hope someone can modify that code can work to extract photo for double cell or couple photo down
here code

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

i attach picture from detail information

thank for your help..
.sst

 

[DanteAmor]

Try this:

Sub InsertPictures()
  'Update 20140513
  Dim PicList() As Variant, PicFormat As String
  Dim Rng As Range, sShape As Shape
  Dim xColIndex As Long, xRowIndex As Long, lLoop As Long
  '
  On Error Resume Next
  PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
  xColIndex = Application.ActiveCell.Column
  If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
      Set Rng = Cells(xRowIndex, xColIndex)
      Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
      If xColIndex = ActiveCell.Column Then
        xColIndex = xColIndex + 1
      Else
        xColIndex = xColIndex - 1
        xRowIndex = xRowIndex + 1
      End If
    Next
  End If
End Sub

 

[muhammad susanto]

hi Dante....working well 100%
thank you very much!!!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.