4

Em Fevereiro solicitei ajuda num codigo para agrupar nomes de fotos que tenho numa pasta (fotos de produtos) pertencentes ao mesmo produto, tal como se pode ver nesta outra pergunta. Meu problema foi solucionado, mas preciso de um ajuste ao codigo que passo a explicar.

Tudo funciona na perfeiçao se os nomes não coincidirem mas se por exemplo eu tiver as fotos:

Produto_4200.jpg

Produto_4200a.jpg

Produto_42000.jpg

Produto_42001.jpg

Produto_42001a.jpg

Produto_42001b.jpg

quando corro o codigo ele junta estas referencias todas na mesma celula como se tratasse apenas de uma referencia...

Produto_4200 (6 fotos)

Produto_4200.jpg, Produto_4200a.jpg, Produto_42000.jpg, Produto_42001.jpg, Produto_42001a.jpg, Produto_42001b.jpg

... e não de 3 produtos diferentes:

Produto_4200 (2 fotos)

Produto_4200.jpg, Produto_4200a.jpg

Produto_42000 (1 foto)

Produto_42000.jpg

Produto_42001 (3 fotos)

Produto_42001.jpg, Produto_42001a.jpg, Produto_42001b.jpg

Será que me podem ajudar? Espero não ter sido muito confuso na minha explicação. O codigo que tenho é o seguinte:

------------------ 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

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

Desde já agradeço toda a ajuda possivel.

6
  • Olá Francisco! Bem legal sua pergunta! Creio que uma boa opção seria verificar o último algarismo para ver se é letra ou número. Pelo que entendi o código da foto se repete (para o mesmo produto) em letras (a, b, c, d, etc) correto? Caso tenha um número (0, 1, 2 etc) seria um novo produto, sim? Posso ajudar no código, mas não é difícil fazer o teste do último caractere. Caso não consiga resolver amanhã posto o código pra ti! ok? Abs
    – Evert
    13/10/2015 às 22:34
  • Olá Evert, obrigado pelo seu interesse. Caso seja um numero será sim um novo produto. Se me puder ajudar nesse teste do ultimo caracter eu agradeço, mas seria utilizando a funçao "If IsNumeric...Then"? O meu problema é encaixar isso tudo sem estragar o codigo que gentilmente me passaram. :) Mais uma vez obrigado, Abs - Francisco
    – xicosantos
    14/10/2015 às 0:07
  • Francisco, consegui fazer o teste se é número, porém não funcionou perfeitamente, pois quando o Excel (Windows) busca os arquivos na pasta, vem por ordem alfabética, sendo os números antes das letras, o que não atende o código acima, que foi muito bem escrito por sinal. Explico: são os arquivos 'P_4200', 'P_4200a' e 'P_42000', essa seria a ordem ideal, porém o Excel me traz 'P_4200', 'P_42000' e 'P_4200a'... =( anyway... tentei fazer alguns ajustes e funções extras, mas acho que ficará mais fácil fazer um novo código... vou tentar e posto aqui assim que conseguir. ok? Desculpe a demora! =)
    – Evert
    16/10/2015 às 20:28
  • Ok Evert... Muito obrigado... :)
    – xicosantos
    16/10/2015 às 20:56
  • Olá. Eu editei a pergunta pra substituir a reprodução do conteúdo pelo link da pergunta anterior. Fica mais legível para todos. Também tirei os agradecimentos. É que esse site não é um fórum, então eles realmente não são necessários. Aliás, se não fez ainda, por favor faça o tour. Boa sorte! :) 15/05/2016 às 19:27

1 Resposta 1

1

Em complementação à função apresentada (muito bem escrita por sinal), alterei alguns códigos e criei outras funções para facilitar a leitura e melhorar o desempenho, realizando os testes necessários conforme solicitado. Segue abaixo:

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

Favor testar o código e verificar se está funcionando conforme desejado.

Espero ter sido útil!

Qualquer coisa estamos a disposição.

Abs

3
  • Grande, aliás, ENORME Evert... tudo funcionando na perfeição. Muito obrigado mesmo. Obrigado pelo seu interesse neste meu problema, obrigado pelo seu tempo dispensado na reestruturação do código e muito obrigado por ser prestável a quem não conhece... Mais uma vez muito obrigado. Disponha...sempre. Abs Francisco Santos
    – xicosantos
    19/10/2015 às 13:00
  • @xicosantos valeu! Disponha! se serviu marque como respondida (seta verde) e dê um 'up' (marcando como resposta útil) ai!! Abs
    – Evert
    19/10/2015 às 13:13
  • Oi novamente. rs Então, fico muito feliz que o seu problema tenha sido resolvido. Porém, saiba que a melhor forma de você agradecer ao colega @Evert pela ajuda dele, é aceitando a resposta dele (clicando no "v" próximo aos votos) e até mesmo votando positivamente nela. :) 15/05/2016 às 19:29

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .