Renomeando vários arquivos

[Frank K Hosaka]

Eu usei o Microsoft Excel para despejar vários arquivos de uma pasta com a rotina GetFileNames( ), e usando a mesma planilha usei para renomear os arquivos com a rotina Renomear( ).

Sub GetFileNames()
    Dim FolderPath As String
    FolderPath = "C:\Users\frank\OneDrive\Documentos\Arquivo Morto\2021"
    Dim Result As Variant
    Dim i As Integer
    Dim MyFile As Object
    Dim MyFSO As Object
    Dim MyFolder As Object
    Dim MyFiles As Object
    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    Set MyFolder = MyFSO.GetFolder(FolderPath)
    Set MyFiles = MyFolder.Files
    Worksheets("Plan1").Activate
    Range("A1").Select
    For Each MyFile In MyFiles
        ActiveCell.Value = MyFile.Name
        ActiveCell.Offset(1, 0).Select
    Next
End Sub

Sub Renomear()
    Worksheets("Plan1").Activate
    Dim path As String
    Dim ArquivoAntigo
    Dim ArquivoNovo
    path = "C:\Users\frank\OneDrive\Documentos\Arquivo Morto\2021\"
    Range("A1").Select
    Do
        ArquivoAntigo = path + ActiveCell.Value
        ArquivoNovo = path + ActiveCell.Offset(0, 3).Value
        Name ArquivoAntigo As ArquivoNovo
        ActiveCell.Offset(1, 0).Select
        teste = ActiveCell.Address
        If teste = "$A$483" Then Stop
    Loop
End Sub