Macro Excel Renombrar archivos

Macro para excel con el fin de renombrar la lista de archivos de la columna A con los nombres de la columna B y en la columna C pone OK si renombre correctamente.

El excel con extensión para macros .xlsm deben estar en el mismo fichero de los archivos a renombrar


La macro la insertan mediante la herramienta programador de excel que abre una instancia de visual basic e insertan un modulo en el libro, en lo posible solo tengan abierto el excel que usaran para renombrar, aunque pueden encontrarse con el libro de macros personal abierto por defecto.

Likes para el compañero Jesús Hernandez que se tomó el trabajo de hacer un video para explicar el codigo, dejó el recurso.

https://www.youtube.com/watch?v=j7wFr-siUx0&ab_channel=Jes%C3%BAsHern%C3%A1ndez


Dim Objeto_Ficheros As Object
Dim Lista_Ficheros As Object
Dim Ficheros As Object
Dim Fichero As Object

Sub RENOMBRAR_ARCHIVOS()
'--------------------------------------------------------------
Set Objeto_Ficheros = CreateObject("Scripting.FileSystemObject")
Set Lista_Ficheros = Objeto_Ficheros.GetFolder(ThisWorkbook.Path & "\")
Set Ficheros = Lista_Ficheros.Files
'--------------------------------------------------------------
x = 1
While ActiveSheet.Cells(x, 1) <> ""
    If ActiveSheet.Cells(x, 3) <> "OK" Then
       For Each Fichero In Ficheros
           If UCase(Fichero) = UCase(ThisWorkbook.Path & "\" & ActiveSheet.Cells(x, 1)) Then
              Fichero.Copy ThisWorkbook.Path & "\" & ActiveSheet.Cells(x, 2), True
              Fichero.Delete
              ActiveSheet.Cells(x, 3) = "OK"
              Exit For
           End If
       Next
    End If
x = x + 1
Wend
End Sub