automatically selecting all files(.jpg) in a folder and copying to excel sheet without using getopen file

[paran]

having container id as sheet name from sheet 15 to last sheet, need a macro to search for a file with sheet name(ABCD1234567) as the file name in mentioned path ( c:\photos), upon matching it should copy all the jpg photos from that file (ABCD1234567) and paste in that sheet name ( sheet name and file name will be same ) and loop will be there till last sheet without using getopenfile and will doing automatically

please help out bro

 

[JEC]

Or the real picture:

Enlarge the row.heights in your sheets before you run this macro.

Sub jec()
 Dim it As Variant, c00 As String, objFolder As String, i As Long, x As Long
 c00 = "C:\Users\XXXX\Pictures\"
  
 With CreateObject("scripting.filesystemobject")
    For i = 15 To Sheets.Count
       objFolder = c00 & Sheets(i).Name
        If .FolderExists(objFolder) Then
           For Each it In .getfolder(objFolder).Files
              x = x + 1
              Sheets(i).Shapes.AddPicture it, False, True, Columns(1).Left, Rows(x + 17).Top, Columns(1).Width, Rows(x + 17).Height
           Next
        End If
       x = 0
    Next
 End With
End Sub

 

[paran]

thanks bro for your effort,but only links are pasted ,we need real jpg image to be pasted in a17 to 5 column and then next row till 5 column ...so on till last jpg image image should of same size

Note, I changed the i =2 to i = 15 in the loop. I tested with 2, forgot to change

 

[JEC]

The last code I posted, does paste the real picture

 

[paran]

Note, I changed the i =2 to i = 15 in the loop. I tested with 2, forgot to change

sorry for the late reply, thanks sir it worked fine, but i want the real image as shown in the image below with same size and small gap between the photos not the link
the pics will be from a17 to 5 column then next row till 5 column and so on .....
thanks for your kind effort once again sir ,awaiting your reply

 

[paran]

sorry for the late reply, thanks sir it worked fine, but i want the real image as shown in the image below with same size and small gap between the photos not the link
the pics will be from a17 to 5 column then next row till 5 column and so on .....
thanks for your kind effort once again sir ,awaiting your reply

yes it pasting the real pic ,but in one column only ,we want as said earlier message it should paste horzontally 5 column the next row and so on
since the column and row set to the estimates above so we can change ,sir can we do it in one blank sheet with column and row increasing the height and width and then again pasting to the required sheet...
90% job is over ,please guide us......

 

[JEC]

Yes but you only keep changing your explanation after I post code. Last try:
You can change the picture sizes yourself if they are not as desired.

Let me know if this works!

Sub jec()
 Dim it As Variant, c00 As String, objFolder As String
 Dim i As Long, x As Long, y As Long, q As Long
 
 c00 = "C:\Users\XXX\Pictures\"
 
 With CreateObject("scripting.filesystemobject")
    For i = 15 To Sheets.Count
       objFolder = c00 & Sheets(i).Name
        If .FolderExists(objFolder) Then
           For Each it In .getfolder(objFolder).Files
              x = x + 1
              y = (x - 1) Mod 5 + 1
              q = (x - 1) \ 5 + 1
              Sheets(i).Shapes.AddPicture it, False, True, (y - 1) * 140 + (10 * y), q * 255 + (10 * q), 140, 255
           Next
        End If
       x = 0
    Next
 End With
End Sub

 

[paran]

Yes but you only keep changing your explanation after I post code. Last try:
You can change the picture sizes yourself if they are not as desired.

Let me know if this works!

Sub jec()
 Dim it As Variant, c00 As String, objFolder As String
 Dim i As Long, x As Long, y As Long, q As Long
 
 c00 = "C:\Users\XXX\Pictures\"
 
 With CreateObject("scripting.filesystemobject")
    For i = 15 To Sheets.Count
       objFolder = c00 & Sheets(i).Name
        If .FolderExists(objFolder) Then
           For Each it In .getfolder(objFolder).Files
              x = x + 1
              y = (x - 1) Mod 5 + 1
              q = (x - 1) \ 5 + 1
              Sheets(i).Shapes.AddPicture it, False, True, (y - 1) * 140 + (10 * y), q * 255 + (10 * q), 140, 255
           Next
        End If
       x = 0
    Next
 End With
End Sub

thanks sir,u r genius,
sorry for change,since i coulkd not explain fully
thanks a lot

 

[paran]

sir good morning
sorry to disturb u again, want an last code in continuation to above code ,to delete the file after copying and the file not found should pop up at last

had tryied wit " kill objfolder" but showing error 53 path not found

please ....

 

[JEC]

Try:

Kill It

 

[paran]

Try:

Kill It

good morning

it kills only photo i want to delete the file name ,pls suggest...