Renomear vários arquivos com VBA

[Gê Reiz]

Bom dia.

Desenvolvi um código para renomear aquivos pdf de uma pasta através do VBA. o Código abre o arquivo (NF), extrai o nome do cliente na nota, fecha o arquivo e renomeia com o nome do cliente. Porém gostaria de fazer através de um laço que pegasse todos os arquivos da pasta e fizesse o mesmo, mas só consegui fazer em um arquivo indicando o caminho dele.

Agradeço qualquer ajuda, e segue o código abaixo:

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Dim AdobeFile As String

Sub Copiar_Dados_PDF_Start()

Dim AdobeApp As String
Dim StartAdobe

    
    
    AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
    AdobeFile = ThisWorkbook.Path & "\NF\Damires - NF.pdf"
     
  
    StartAdobe = Shell("" & AdobeApp & " " & """" & AdobeFile & """" & "", 1)
    
    AdobeFile = VBA.Replace(VBA.Right(AdobeFile, VBA.Len(AdobeFile) - VBA.InStrRev(AdobeFile, "\")), ".pdf", "")
    
    Application.OnTime Now + TimeValue("00:00:03"), "FirstStep"
    
End Sub


Private Sub FirstStep()
    SendKeys ("^a")
    SendKeys ("^c")
    Application.OnTime Now + TimeValue("00:00:02"), "SecondStep"
    
End Sub


Private Sub SecondStep()
Dim ws As Worksheet
Dim i!

    
    On Error Resume Next
     AppActivate Application.Caption
    On Error GoTo 0
  
   With ThisWorkbook
   .Activate
    For i = 1 To .Worksheets.Count
    If .Sheets(i).Name = "..." Then
    .Sheets(i).Activate
    .Sheets(i).Cells.Clear
     Exit For
    End If
     Next
    End With
    
    Sheets("...").Range("A1").Activate
    SendKeys ("^v")
    Sleep 1000
    SendKeys ("{RIGHT}")

    Application.OnTime Now + TimeValue("00:00:02"), "fechapdf"
    
    
End Sub


Private Sub fechapdf()

Dim KillPdf As String

KillPdf = "TASKKILL /F /IM AcroRd32.exe"
Shell KillPdf, vbHide

Application.OnTime Now + TimeValue("00:00:02"), "extrairRazao"

End Sub


Private Sub extrairRazao()

Dim Razao As String


Razao = Sheets("...").Range("A17").Value
pontos = InStr(1, Razao, ":")
qtdeLetras = Len(Razao)
nome = Right(Razao, qtdeLetras - pontos)
Sheets("...").Range("E5").Value = nome

' MsgBox nome

Application.OnTime Now + TimeValue("00:00:02"), "renomeaPfd"

End Sub


Private Sub renomeaPfd()

Name "C:\Users\Georgie\Documents\ENVIO DE EMAILS\NF\Damires - NF.pdf" As "C:\Users\Georgie\Documents\ENVIO DE EMAILS\NF\" & Sheets("...").Range("E5").Value & " - NF.pdf"


End Sub

[Alyson Ronnan Martins]

Olha se te ajuda:

Public Function ListaArquivos(ByVal Caminho As String) As String()
    'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime
    Dim FSO As New FileSystemObject
    Dim result() As String
    Dim Pasta As Folder
    Dim Arquivo As File
    Dim Indice As Long
 
 
    ReDim result(0) As String
    If FSO.FolderExists(Caminho) Then
        Set Pasta = FSO.GetFolder(Caminho)
 
        For Each Arquivo In Pasta.Files
            Indice = IIf(result(0) = "", 0, Indice + 1)
            ReDim Preserve result(Indice) As String
            result(Indice) = Arquivo.Name
        Next
    End If
 
    ListaArquivos = result
ErrHandler:
    Set FSO = Nothing
    Set Pasta = Nothing
    Set Arquivo = Nothing
End Function

Private Sub ListaArquivos()
    Dim arquivos() As String
    Dim lCtr As Long
    arquivos = ListaArquivos("C:\temp")
    For lCtr = 0 To UBound(arquivos)
      Debug.Print arquivos(lCtr)
'Seu comando aqui...
    Next
End Sub

 

[Gê Reiz]

Boa tarde.

Chegando em casa a noite, irei olhar com mais calma. 

Este código lista os arquivos, é isso??

 

 

[Alyson Ronnan Martins]

O primeiro lista arquivos e o segundo trabalha com a lista. 

Você coloca o seu o código no segundo.

[Gê Reiz]

Bom dia. 

Fiz algumas alterações no Código acima e consegui adpatar a minha necessidade!

Muito obrigado pela ajuda!

[Alyson Ronnan Martins]

Show!!!