VBA to search for folders and concatenate file names

Navigation
1

I need to evolve the following code to concatenate data in a certain way. I have a folder with product pictures (several photos for each product) and I want Excel to search the name of the photos and write the names of the photos related to each product in a cell and separated by a comma.

Another issue is that for each product photos can have different extensions ie you can have JPG and / or PNG and / or JPEG >. (see examples)

The name of the photos is the same as the reference of the product and if the product has more than one photo the name is differentiated by a letter of the alphabet at the end of the name and before the point and the extension. Ex: ac2345 a .jpg or 023198AA b .jpg or GDV7YDX c .jpeg The name can be just numbers, or just letters or a mix of numbers and letters.

Another condition is that in order to exist an image ac2345 a .jpg there must be an ac2345.jpg (or png or jpeg) image to exist a GDV7YDX c .jpeg must have a GDV7YDX.jpg (or png or jpeg) image, a GDV7YDX a .jpg (or png or jpeg) image and a GDV7YDX b (or png or jpeg).

In total there may be 1000, 2000, 3000 photos or more in the folder and for each product there may be 1 or 2 or 3 or 15, etc. photos

Example

  • Product PHOTOS ac2345

    • ac2345.png
    • ac2345a.jpg
    • ac2345b.png

  • Product PHOTOS 106

    • 106.jpeg
    • 106a.jpg
    • 106b.jpg
    • 106c.jpg
    • 106d.jpg

  • Product PHOTOS 023198AA

    • 023198AA.png
    • 023198AAa.png
    • 023198AAb.jpg

  • GDV7YDX product PHOTOS

    • GDV7YDX.png
    • GDV7YDXa.png
    • GDV7YDXb.jpg
    • GDV7YDXc.jpeg
    • GDV7YDXd.jpg
    • GDV7YDXe.png

Code

The code I submit searches all the files in a folder and writes the names of the files on one sheet but writes each name in a separate cell and all in column A.

Example:

  

Cell A1 = ac2345.png

     

Cell A2 = ac2345a.jpg

     

Cell A3 = ac2345b.png

     

Cell A4 = 106.jpeg

     

Cell A5 = 106a.jpg

     

Cell A6 = 106b.jpg

     

Cell A7 = 106c.jpg

     

Cell A8 = 106d.jpg

     

Cell A9 = 023198AA.png

     

Cell A10 = 023198AAa.png

     

Cell A11 = 023198AAb.jpg

     

Cell A12 = GDV7YDX.png

     

Cell A13 = GDV7YDXa.png

     

Cell A14 = GDV7YDXb.jpg

     

Cell A15 = GDV7YDXc.jpeg

     

Cell A16 = GDV7YDXd.jpg

     

Cell A17 = GDV7YDXe.png

Problem

What I need is that in the same cell the names for each product are separated by commas.

Example:

  

Cell A1 = ac2345.png, ac2345a.jpg, ac2345b.png

     

Cell A2 = 106.jpeg, 106a.jpg, 106b.jpg, 106c.jpg, 106d.jpg

     

Cell A3 = 023198AA.png, 023198AAa.png, 023198AAb.jpg

     

Cell A4 = GDV7YDX.png, GDV7YDXa.png, GDV7YDXb.jpg, GDV7YDXc.jpeg, GDV7YDXd.jpg, GDV7YDXe.png

Here is the code I have: 

Sub GetJPGandPNGandJPEG()    
   Dim X As Long, LastDot As Long, Path As String, FileName As String, F(0 To 9) As String
   Path = "C:\teste\"
   FileName = Dir(Path & "*.*p*g")
   Do While Len(FileName)
      LastDot = InStrRev(FileName, ".")
   If LCase(Mid(FileName, LastDot)) = ".jpg" Or LCase(Mid(FileName, LastDot)) = ".png" Or LCase(Mid(FileName, LastDot)) = ".jpeg" Then
      If Left(FileName, 1) Like "#" Then
         F(Left(FileName, 1)) = F(Left(FileName, 1)) & ", " & FileName
      End If
   End If

   FileName = Dir
   Loop
      For X = 0 To 9
         Cells(X + 1, "A").Value = Mid(F(X), 3)
      Next
      Range("A1:A10").SpecialCells(xlBlanks).Delete

End Sub

Can anyone help me? Thank you in advance.

    
asked by anonymous 09.02.2015 / 09:31

2 answers

1

You can reference the Micrsoft Scripting Runtime library to make use of File System Object (FSO) objects, as the example here . This way you will work with all the files that are in the directory, from the result loop of the files, make a comparison with the product name, if it concatenates the result, just go to the next line if it is another product. / p>     

09.02.2015 / 14:51
1

I made an example based on your (without reference to the library I mentioned): 

Sub GetJPGandPNGandJPEG()

Dim Path As String
Dim FileName As String
Dim LastDot As Long
Dim FileNameAux As String
Dim FileNameConc As String
Dim LastRow As Long

Path = "C:\Temp\Imagens\"
FileName = Dir(Path & "*.*p*g")

Do While Len(FileName)
  LastDot = InStrRev(FileName, ".")
  If LCase(Mid(FileName, LastDot)) = ".jpg" Or LCase(Mid(FileName, LastDot)) = ".png"  Or LCase(Mid(FileName, LastDot)) = ".jpeg" Then
    If (FileNameAux = vbNullString) Then
      FileNameAux = Replace(FileName, LCase(Mid(FileName, LastDot)), "")
    End If

    If (InStr(1, FileName, FileNameAux, vbTextCompare)) Then
      If (FileNameConc = vbNullString) Then
      FileNameConc = FileName
    Else
      FileNameConc = FileNameConc & ", " & FileName
    End If
  Else
    If (FileNameConc = vbNullString) Then
      FileNameConc = FileName
    End If
    LastRow = Plan1.Cells(Plan1.Rows.Count, 1).End(xlUp).Row + 1
    Plan1.Cells(LastRow, 1) = FileNameConc
    FileNameAux = Replace(FileName, LCase(Mid(FileName, LastDot)), "")
    FileNameConc = FileName
  End If
End If
FileName = Dir
Loop
LastRow = Plan1.Cells(Plan1.Rows.Count, 1).End(xlUp).Row + 1
Plan1.Cells(LastRow, 1) = FileNameConc
End Sub

The result looks like this:

    
09.02.2015 / 15:47
How to put a subtitle under the application name in the bar menu Get the user last login