Dear all,


i have a code today as below to insert all picture in column B1 and comment in column A1 from a folder that is working fine.

My new target is to insert all picture automatically as following

- starting to insert the first picture in column B5 with her name in B6
- then insert the next picture in column D5 with her name in D6
- then insert next picture in column B8 with her name in B9
- then insert the next picture in column D8 with her name in D9
- and so on for the next row same as above until all picture have been inserted

How to modify the code below to achieve this target?



Sub AddOlEObject()


Dim mainWorkBook As Workbook


Set mainWorkBook = ActiveWorkbook
Sheets("Survey_Picture").Activate
Folderpath = "C:\Users\Administrator\Desktop\QUALIPAC"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
For Each fls In listfiles
strCompFilePath = Folderpath & "" & Trim(fls.Name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
Sheets("Survey_Picture").Range("A" & counter).Value = fls.Name
Sheets("Survey_Picture").Range("B" & counter).ColumnWidth = 25
Sheets("Survey_Picture").Range("B" & counter).RowHeight = 100
Sheets("Survey_Picture").Range("B" & counter).Activate
Call insert(strCompFilePath, counter)
Sheets("Survey_Picture").Activate
End If
End If
Next
mainWorkBook.Save
End Sub


Function insert(PicPath, counter)
'MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 50
.Height = 70
End With
.Left = ActiveSheet.Range("B" & counter).Left
.Top = ActiveSheet.Range("B" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function





Best regards

TITI