Rename multiple files with VBA

Question

Good morning everyone. I adapted a code to rename several file with vba, which performs the following function:

1. I select the folder,

2. The VBA opens the PDF (Invoice) , extracts the information from the text and with the social reason closes the pdf and renames it with the extracted name.

The problem is that after renaming the first file correctly the execution of the code hangs, and it is necessary to finish the process.

Follow the code below.

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
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 selecionar_pasta()
 Dim box As Folder
 Dim arquivos() As String
 Dim lCtr As Long
 Dim AdobeApp As String
 Dim StartAdobe
 Dim Arquivo As String
 Dim NomeAntigo As String
 Dim NomeNovo As String

 
     On Error Resume Next
     linha = 1
     ultima_linha = Sheets("teste").Cells(Rows.Count, 1).End(xlUp).Row
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Buscar pasta"
            .InitialFileName = ThisWorkbook.Path
            .Show
            .AllowMultiSelect = False
            Pasta = .SelectedItems(1)
        End With
   
    TextBox1 = box
    

    arquivos = ListaArquivos(Pasta)
    Sleep 1000
    For lCtr = 0 To UBound(arquivos)
      Debug.Print arquivos(lCtr)
        'Inserir código aqui'
        
        'Cells(linha, 1).Value = arquivos(lCtr)
        'linha = (linha + 1)
        'Sleep 500
        
            
          pdf = arquivos(lCtr)
        
          AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
          
          Sleep 2000
          
          
        
          For Each pdf In Pasta
          
          
          Adobefile = Pasta & "\" & pdf
        
          StartAdobe = Shell("" & AdobeApp & " " & """" & Adobefile & """" & "", 1)
         
        
          Sleep 2000
              
            
            Application.SendKeys ("^a")

            Application.SendKeys ("^c")
             Sleep 2000

           
           
           Dim KillPdf As String

           KillPdf = "TASKKILL /F /IM AcroRd32.exe"
           Shell KillPdf, vbHide
           
                      
           AppActivate Application.Caption
        
        
            
            Sheets("teste").Range("A1").Activate
            SendKeys ("^v")
                     
            DoEvents
                
            
            
            
            Dim Razao As String


            Razao = Sheets("teste").Range("A17").Value
            pontos = InStr(1, Razao, ":")
            qtdeLetras = Len(Razao)
            Nome = Right(Razao, qtdeLetras - pontos)
            Sheets("teste").Range("C1").Value = Nome
            
            
            
            
              Do While Not IsEmpty(Range("C1"))
              
             
                NomeAntigo = Pasta & "\" & pdf
                    
                NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
                
                Sheets("teste").Range("C2").Value = Adobefile
                    
                Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
                    

                
                Name NomeAntigo As NomeNovo
                
                
               
               ' DoEvents
                
        
              Loop
    
   
   
         ' MsgBox "Nomes dos arquivos alterados!", vbOKOnly, "Processo Concluído"
            
            
        
            Next
        
        
    Next
    
     ' MsgBox ("Arquivos Encontrados = ") & (linha - 1)
     
     
      

End Sub

I have tried everything, and I could not solve this problem, if I remove Do while, it runs normally, however it would not rename the files. If I make this loop, it renames only the first and general lock.



Any lightening es, thank you.

Answer 1

You have created an infinite loop in:

Do While Not IsEmpty(Range("C1"))

The loop will always continue running because the C1 range is not empty, since it has been filled a few lines before in:

Sheets("teste").Range("C1").Value = Nome

Change your code to add a valid condition for loop output or use another alternative to your logic.

For example, use a IF in place of DO WHILE:

If Not IsEmpty(Range("C1")) Then

    NomeAntigo = Pasta & "\" & pdf
    
    NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
    
    Sheets("teste").Range("C2").Value = Adobefile
    
    Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"
    
    Name NomeAntigo As NomeNovo
    
    ' DoEvents

End If