I am using the following code to insert multiple images from a folder every 50 cells.
What does the code do ?
1- Open file dialog
2- Import the photos (4 photos per folder)
3- Resize them
4- Insert them in specific location (every 50 cells)
The code is perfectly working so far as it should be.
What is the requested change ?
1- I want to Run the code for 2 times to add photo from the first and then the second folder. How to start inserting photos for the second run from rows 250 and each 50 rows on. For example row 250, 300, 350, 400
It would be great if somebody could help me doing this.
Sub AddPhotos()
Dim mainWorkBook As Workbook
Dim fdl As FileDialog
Set mainWorkBook = ActiveWorkbook
Sheets("Sheet1").Activate
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then Folderpath = .SelectedItems(1)
End With
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 + 50
Sheets("Sheet1").Range("A" & counter).ColumnWidth = 10
Sheets("Sheet1").Range("A" & counter).RowHeight = 15
Sheets("Sheet1").Range("A" & counter).Activate
Call insert(strCompFilePath, counter)
Sheets("Sheet1").Activate
End If
End If
Next
mainWorkBook.Save
End Sub
Function insert(PicPath, counter)
MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoFalse
.Width = 465
.Height = 450
End With
.Left = ActiveSheet.Range("A" & counter).Left
.Top = ActiveSheet.Range("A" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
Bookmarks