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]

Don't understand your question completely, but this is how you list all jpg files of a specific folder(including subfolders) into Excel

Sub jec()
Dim a, c00
c00 = "C:\Users\xxxx\pictures\*jpg"
a = Split(CreateObject("wscript.shell").Exec("cmd /c Dir """ & c00 & """ /b/s").StdOut.ReadAll, vbCrLf)
Cells(2, 10).Resize(UBound(a)) = Application.Transpose(a)
End Sub

 

[paran]

thanks for your reply bro

i have more than 40 sheets in my workbook and it increases by feeding additional estimates
after 15th sheet each sheet is named with the container nos and it goes on till n th sheet for eg texu1234567/crxu23156478 etc
for all these container we have damage photo which is stored in c:/photos

now macro has to search for file name ( which is sheet name itself) and select all photos
after these i have the code which is running as

Dim PicList() As Variant
'                                                                Dim PicFormat As String
'                                                                Dim rng As Range
'                                                                Dim sShape As Shape
'
'                                                                            Sheets("test").Select
'                                                                            Range("a1").Select
'                                                                            ActiveSheet.DrawingObjects.Select
'                                                                            Selection.Delete
'                                                                            Range("A1").Select
'                                                                            Cells.Select
'                                                                            Selection.ColumnWidth = 36.41
'                                                                            Selection.RowHeight = 276
'                                                                            Range("a1").Select
'
'                                                                Let xColIndex = n
'                                                                Let xRowIndex = m
'                                                                On Error Resume Next
'                                                                PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
'                                                                m = 1
'                                                                n = 1
'
'                                                                If IsArray(PicList) Then
'                                                                       For lLoop = LBound(PicList) To UBound(PicList)
'                                                                            Set rng = Cells(m, n)
'                                                                            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height)
'                                                                            n = n + 1
'                                                                                        If n = 6 Then
'                                                                                                        m = m + 1
'                                                                                                        n = 1
'                                                                                        End If
'                                                                        Next
'                                                                   End If
'                                                                Range("a1").Select
'                                                                Columns("A:e").ColumnWidth = 37
'                                                                Rows("1:40").RowHeight = 280
'                                                                Range("a1").Select
'                                                                ActiveSheet.DrawingObjects.Select
'                                                                Selection.Copy
'                                                                Sheets(p).Select
'                                                                Range("A23").Select
'                                                                ActiveSheet.Paste
'                                                                Range("A1").Select
'
'Next p

we dont want getopenfile application ,macro should search file as sheet name and execute till last sheet

will appreciate your kind response
rgds

 

[paran]

thanks for your reply bro

i have more than 40 sheets in my workbook and it increases by feeding additional estimates
after 15th sheet each sheet is named with the container nos and it goes on till n th sheet for eg texu1234567/crxu23156478 etc
for all these container we have damage photo which is stored in c:/photos

now macro has to search for file name ( which is sheet name itself) and select all photos
after these i have the code which is running as

Dim PicList() As Variant
'                                                                Dim PicFormat As String
'                                                                Dim rng As Range
'                                                                Dim sShape As Shape
'
'                                                                            Sheets("test").Select
'                                                                            Range("a1").Select
'                                                                            ActiveSheet.DrawingObjects.Select
'                                                                            Selection.Delete
'                                                                            Range("A1").Select
'                                                                            Cells.Select
'                                                                            Selection.ColumnWidth = 36.41
'                                                                            Selection.RowHeight = 276
'                                                                            Range("a1").Select
'
'                                                                Let xColIndex = n
'                                                                Let xRowIndex = m
'                                                                On Error Resume Next
'                                                                PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
'                                                                m = 1
'                                                                n = 1
'
'                                                                If IsArray(PicList) Then
'                                                                       For lLoop = LBound(PicList) To UBound(PicList)
'                                                                            Set rng = Cells(m, n)
'                                                                            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height)
'                                                                            n = n + 1
'                                                                                        If n = 6 Then
'                                                                                                        m = m + 1
'                                                                                                        n = 1
'                                                                                        End If
'                                                                        Next
'                                                                   End If
'                                                                Range("a1").Select
'                                                                Columns("A:e").ColumnWidth = 37
'                                                                Rows("1:40").RowHeight = 280
'                                                                Range("a1").Select
'                                                                ActiveSheet.DrawingObjects.Select
'                                                                Selection.Copy
'                                                                Sheets(p).Select
'                                                                Range("A23").Select
'                                                                ActiveSheet.Paste
'                                                                Range("A1").Select
'
'Next p

we dont want getopenfile application ,macro should search file as sheet name and execute till last sheet

will appreciate your kind response
rgds

Sir pls help me out......

 

[JEC]

It is not clear to me. What do you want with the photos? How many photos per sheet? Where to paste etc…

 

[paran]

It is not clear to me. What do you want with the photos? How many photos per sheet? Where to paste etc…

please be advised that we have estimates from sheet 15 onwards to last sheet these sheets will increase upon adding, now we want the macro to open given file and select all the jpg file ( 100 photos max) and paste in sheet 15 below the estimate i.e a17 cell ,same the loop should continue till last sheet without using application openfile ,the macro should automatically search the file in given folder and copy all the images and execute the job

or just advise us macro to search for a file name ,if matches it should select all jpg images inside the file and remaining execution i have the code ,which i have sent u
i will remove the application open file and loop through

 

[JEC]

But you only want the links of the jpg files listed right? Or the real picture?

 

[JEC]

This is the way

Edit: changed 2 to 15 in loop

Sub jec()
 Dim ar, it As Variant, c00 As String, i As Long, x As Long
 ReDim ar(150)
 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
              ar(x) = it.Path
              x = x + 1
           Next
          ThisWorkbook.Sheets(i).Range("A17").Resize(x) = Application.Transpose(ar)
        End If
       x = 0
    Next
 End With
End Sub

 

[paran]

But you only want the links of the jpg files listed right? Or the real picture?

yes,only want the real pic of jpg to be selected all inside the file

 

[JEC]

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