VBA to search for photos in a folder and concatenate file names without duplicating

Question

VBA to search for photos in a folder and concatenate file names without duplicating

Navigation

#1 by (1 votes)

4

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

Everything works perfectly if the names do not match but if for example I have the photos:

Product_4200.jpg

Product_4200a.jpg

Product_42000.jpg

Product_42001.jpg

Product_42001a.jpg

Product_42001b.jpg

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

Product_4200 (6 photos)

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

... and not from 3 different products:

Product_4200 (2 photos)

Product_4200.jpg, Product_4200a.jpg

Product_42000 (1 photo)

Product_42000.jpg

Product_42001 (3 photos)

Product_42001.jpg, Product_42001a.jpg, Product_42001b.jpg

Can you help me? I hope I was not too confused in my explanation. The code I have is the following:

------------------ 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 you can get.

vba

asked by anonymous 10.10.2015 / 19:13

1 answer

Capture Machine ID with C # Importing PDF Data into PHP

score 1 · Answer 1

In addition to the function presented (very well written by the way), I changed some of the codes and created other functions to facilitate reading and improve performance, performing the necessary tests as requested. Follow 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 see if it is working as intended.

I hope I have been useful!

Anything is at our disposal.

Abs