Excel Macro copia e cola PDF a partir da busca de uma lista

[pedroch]

Bom dia pessoal, 

 

Consegui com ajuda do chat gpt fazer uma macro que copia os arquivos da coluna, os busca na pasta de origem e cola na pasta de destino que eu escolher. Até ai tudo bem, ele acerta bem. Porém agora eu queria que ele retornasse em qualquer coluna a lista dos itens da coluna A que não foram encontrados na busca para eu saber se algum arquivo não foi encontrado porém mesmo com o chat gpt me ajudando ele apresenta problemas e não chega a lugar nenhum. Alguém conseguiria me ajudar?

 

A macro original que citei está no modulo 1

 

O módulo 9 o chat gpt me ajudou, ele encontra os arquivos que eu peço mas ele me retorna na lista como se não tivesse encontrado os arquivos, mas está errado.

 

Qual seria o erro? Aceito sugestões, não sei usar python mas pode  ser mais simples... ou pode ser um erro bobo que está acontecendo

Copiar e colar pdfs de ordens - Copy.xlsx

[Midori]

O nome dos arquivos são esses da coluna A, 48083823.pdf, 4808382.pdf...?

 

[pedroch]

sim, esses da coluna A são os arquivos que eu to procurando. Caso algum deles não for achado eu quero que ela retorne na coluna E o que ele não achou para eu saber se está faltando alguma coisa

[Midori]

Você pode fazer só um loop na tabela e usar a função Dir para testar se o arquivo existe, é bem mais simples. Array é desnecessário.

 

Não precisa de FSO e Shell para isso. O VBA tem FileCopy e, para pegar o diretório, FileDialog.

[pedroch]

Tentei aqui mas infelizmente a IA só me atrapalhou. Meu nível de conhecimento não é tão avançado, não consegui implementar as sugestões que você falou

[Midori]

Veja se assim resolve,

 

Sub CopiaArquivos()
    Dim Dialogo As FileDialog
    Dim Area    As Range
    Dim Nome    As Range
    Dim TermoNE As Range
    Dim DirOrig As String
    Dim DirDest As String
    Dim Arquivo As String
    
    Set Area = [A2:A30]
    Set TermoNE = [E2]
    Set Dialogo = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dialogo.Title = "Origem"
    Dialogo.Show
    If Dialogo.SelectedItems.Count = 1 Then DirOrig = Dialogo.SelectedItems(1)
    Dialogo.Title = "Destino"
    Dialogo.Show
    If Dialogo.SelectedItems.Count = 1 Then DirDest = Dialogo.SelectedItems(1)

    If DirOrig <> "" And DirDest <> "" Then
        For Each Nome In Area
            Arquivo = DirOrig & "\" & Trim(Nome.Value) & ".pdf"
            If Dir(Arquivo) <> "" Then
                Call FileCopy(Arquivo, DirDest & "\" & Trim(Nome.Value) & ".pdf")
            Else
                TermoNE.Value = Nome.Value
                Set TermoNE = TermoNE(2)
            End If
        Next Nome
    Else
        MsgBox "Diretório(s) inválido(s)", vbExclamation
    End If
End Sub

 

[pedroch]

@Midori  deu certo,

 

eu fiz assim e também foi um resultado positivo, obrigado pelas dicas:

Sub CopiarPDFsSimplificadosCERTA()
    Dim rngBuscas As Range
    Dim termo As Range
    Dim pastaOrigem As String, pastaDestino As String
    Dim arquivo As String
    Dim termosNaoEncontrados As String
    Dim linha As Integer
    Dim totalCopiados As Integer, totalNaoEncontrados As Integer

Application.ScreenUpdating = False

    With ThisWorkbook.Sheets("Sheet1").Range("E2:E76")
    ' Centralizar o texto
    .HorizontalAlignment = xlCenter
    
    ' Pintar as células de amarelo
    .Interior.Color = RGB(226, 239, 218)
    
    ' Adicionar moldura
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlThick
    
    ' Deixar o texto em negrito
    .Font.Bold = True

End With

    ' Inicialize os contadores
    totalCopiados = 0
    totalNaoEncontrados = 0

    ' Use FileDialog para obter o diretório
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Selecione a pasta de origem dos PDFs"
        If .Show = -1 Then
            pastaOrigem = .SelectedItems(1) & "\"
        Else
            MsgBox "Nenhuma pasta de origem selecionada. A cópia de PDFs foi cancelada."
            Exit Sub
        End If

        .Title = "Selecione a pasta de destino"
        If .Show = -1 Then
            pastaDestino = .SelectedItems(1) & "\"
        Else
            MsgBox "Nenhuma pasta de destino selecionada. A cópia de PDFs foi cancelada."
            Exit Sub
        End If
    End With

    ' Defina o intervalo de busca
    Set rngBuscas = ThisWorkbook.Sheets("Sheet1").Range("A2:A" & ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row)

    ' Limpe a coluna E
    ThisWorkbook.Sheets("Sheet1").Columns("E:E").Clear
    linha = 2

' Verifique se a célula E1 está vazia
    If ThisWorkbook.Sheets("Sheet1").Range("E1").Value <> "" Then
        ' Se a célula E1 não estiver vazia, insira uma nova linha no início da coluna E
        ThisWorkbook.Sheets("Sheet1").Rows(1).Insert
    End If

    ' Adicione o título "Termos não encontrados" na célula E1
    ThisWorkbook.Sheets("Sheet1").Range("E1").Value = "Termos não encontrados"
    
    ' Verifique cada termo de pesquisa
    For Each termo In rngBuscas
        If termo.Value <> "" Then
            Dim encontrado As Boolean
            encontrado = False
            ' Divida o termo de pesquisa em palavras
            Dim palavras As Variant
            palavras = Split(termo.Value, " ")
            ' Verifique se todas as palavras estão presentes no nome do arquivo
            arquivo = Dir(pastaOrigem & "*.pdf")
            Do While arquivo <> ""
                Dim todasPalavrasPresentes As Boolean
                todasPalavrasPresentes = True
                For Each palavra In palavras
                    If InStr(1, arquivo, palavra, vbTextCompare) = 0 Then
                        todasPalavrasPresentes = False
                        Exit For
                    End If
                Next palavra
                If todasPalavrasPresentes Then
                    ' Se o arquivo existir, copie para a pasta de destino
                    FileCopy pastaOrigem & arquivo, pastaDestino & arquivo
                    totalCopiados = totalCopiados + 1
                    encontrado = True
                    Exit Do
                End If
                arquivo = Dir
            Loop
            ' Se o arquivo não existir, adicione o termo à lista de termos não encontrados
            If Not encontrado Then
                ThisWorkbook.Sheets("Sheet1").Cells(linha, "E").Value = termo.Value
                linha = linha + 1
                totalNaoEncontrados = totalNaoEncontrados + 1
            End If
        End If
    Next termo

  ' Exiba uma caixa de mensagem com o número total de arquivos copiados e não encontrados
    MsgBox "Operação finalizada. Total de " & totalCopiados & " arquivos copiados com sucesso. Total de " & totalNaoEncontrados & " termos não encontrados.", vbInformation

    ' Centralize os termos não encontrados na coluna E
    With ThisWorkbook.Sheets("Sheet1").Range("E1")
    .Font.Bold = True
        End With
        
    With ThisWorkbook.Sheets("Sheet1").Columns("E:E")
        .HorizontalAlignment = xlCenter

    End With
    
    
    Application.ScreenUpdating = True
End Sub