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

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,762
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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
VBA 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
 

Attachments

  • extract_image couple.png
    extract_image couple.png
    69.8 KB · Views: 3

Some videos you may like

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Try this:

VBA Code:
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,119,099
Messages
5,576,128
Members
412,698
Latest member
Lilly13m
Top