VBA for searching photos in a folder and concatenating filenames without duplicating

Question

In February I asked for help in a code to group photo names I have in a folder (product photos) belonging to the same product, such as can be seen in this other question. My problem has been solved, but I need an adjustment to the code that I will explain.

Everything works perfectly if the names don’t match but if for example I have the photos:

Product

Production_4200a.jpg

Product

Product

Production_42001a.jpg

Production_42001b.jpg

when I run the code it joins all these references in the same cell as if it were just a reference...

Product_4200 (6 photos)

Production_4200.jpg, Product_4200a.jpg, Product_42000.jpg, Product_42001.jpg, Product_42001a.jpg, Product_42001b.jpg

... and not 3 different products:

Product_4200 (2 photos)

Production_4200.jpg, Product_4200a.jpg

Product_42000 (1 photo)

Product

Product_42001 (3 photos)

Production_42001.jpg, Product_42001a.jpg, Product_42001b.jpg

Can you help me? I hope I haven’t been too confused in my explanation. The code I have is this::

------------------ Codigo (Paulo Balbino)-----------------------------

        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

---------------------------------------------------------------------

Thanks in advance for all the help possible.

Answer 1

In addition to the function presented (very well written by the way), I changed some codes and created other functions to facilitate reading and improve performance, performing the necessary tests as requested. Goes below:

Option Explicit

Sub GetJPGandPNGandJPEG()

Dim Path As String
Dim FileName As String
Dim LastDot As Long
Dim LastRow As Long
Dim Count As Integer
Dim FileAddress As String
Dim FileNameAux As String


    ' Busca os dados
    Path = "C:\temp\imagens\"
    FileName = Dir(Path & "*.*p*g")
    Count = 1

    ' Verifica variável com os dados na pasta especificada
    Do While Len(FileName)

        LastDot = InStrRev(FileName, ".")

        ' Verifica se são fotos com as seguintes extensões: jpg, png, jpeg
        If LCase(Mid(FileName, LastDot)) = ".jpg" Or LCase(Mid(FileName, LastDot)) = ".png" Or LCase(Mid(FileName, LastDot)) = ".jpeg" Then

            FileNameAux = LCase(FileName)

            If (IsNumeric(Right(Replace(FileNameAux, LCase(Mid(FileNameAux, LastDot)), ""), 1))) And Count > 1 Then

                writeToCell FileName

            Else
                FileNameAux = Mid(FileName, 1, LastDot - 2)
                FileAddress = CheckIfExist(FileNameAux)

                If FileAddress <> "" Then
                    writeToCell FileName, FileAddress
                Else
                    writeToCell FileName
                End If
            End If

        End If
        FileName = Dir
        Count = Count + 1
    Loop
End Sub

Sub writeToCell(FileName As String, Optional ENDERECO As String)
'
' Verifica se foi passado um endereço e escreve os dados na célula
'
Dim LastRow As Long

    If ENDERECO <> "" Then
        Range(ENDERECO).Select
        ActiveCell.FormulaR1C1 = ActiveCell.Text & ", " & FileName
    Else
        ' Forma antiga de escrever os dados na planilha
        LastRow = Plan1.Cells(Plan1.Rows.Count, 1).End(xlUp).Row + 1
        Plan1.Cells(LastRow, 1) = FileName
    End If
End Sub

Function CheckIfExist(NOMEARQUIVO As String) As String
'
' Função para checar se já existe o nome do arquivo na coluna "A"
'
Dim Rng As Range        ' Range com os dados existentes na coluna "A"
Dim Dn As Range         ' Dados do Range
Dim Ln As Long          ' Tamanho do texto
Dim FileAux As String   ' Variável Auxiliar

    FileAux = NOMEARQUIVO
    Ln = Len(FileAux)

    Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

    For Each Dn In Rng
        If LCase(Mid(Dn.Value, 1, Ln)) = LCase(FileAux) Then
            CheckIfExist = Dn.Address
            Exit Function
        End If
    Next Dn

    ' Caso não encontre retorna zero
    CheckIfExist = ""

End Function

Please test the code and check if it is working as desired.

I hope I’ve been helpful!

Anything we can spare.

Abs