macro to rename pdf files

Hi,

(Updated post)

The subroutine below will rename the PDFs in a specific folder of your choice to the folder name and then copy all the PDFs to a single new location. There are two places for you to change (e.g. where it says "Change here" denoting the start folder and the folder where the files should be copied to).

I have put in a safeguard against it overwriting files when copying but always, always keep a backup copy of your files. Never run macros on the originals because there is always a slight possibility the results will be different than you expected.

Here is the code:

Option Explicit

Sub RenameThenCopyFilesInFolder()
  Dim myFolder$
  ' Pick folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = "C:\Temp\Old Folder"                         '<<< Change here
        .Show
        If .SelectedItems.Count > 0 Then myFolder = .SelectedItems(1) & "\" Else Exit Sub
    End With
  ' Loop through all subfolders
    ListFilesInFolder myFolder, True
End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
  Dim Oldfile$, NewFile$, NewFolder$, fso As Object, SourceFolder, FileItem, SubFolder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = fso.GetFolder(SourceFolderName)
        For Each FileItem In SourceFolder.Files
            If FileItem.Name Like "*" & ".pdf" Then
              With fso
                Oldfile = SourceFolder.Path & "\" & FileItem.Name
                NewFile = SourceFolder.Path & "\" & .GetBaseName(SourceFolder) & ".pdf"
                NewFolder = "C:\Temp\New Folder"                        '<<< Change here
              ' Upadate the file names
                .MoveFile Oldfile, NewFile
              ' Copy pdfs to new folder
                .CopyFile NewFile, NewFolder & .GetBaseName(NewFile) & ".pdf", False
              End With
            End If
        Next
            If IncludeSubfolders Then
                For Each SubFolder In SourceFolder.SubFolders
                    ListFilesInFolder SubFolder.Path, True
                Next SubFolder
            End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fso = Nothing
End Sub

Let me know how it works out.

abousetta

Hi,

I simplified it a bit. It's working fine from my end.

Option Explicit

Sub RenameThenCopyFilesInFolder()
  Dim myFolder$
  ' Pick folder
    myFolder = "C:\Temp\Old Folder\"                                                        '<<< Change here
  ' Loop through all subfolders
    ListFilesInFolder myFolder, True
End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
  Dim Oldfile$, NewFile$, NewFolder$, fso As Object, SourceFolder, FileItem, SubFolder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = fso.GetFolder(SourceFolderName)
        For Each FileItem In SourceFolder.Files
            If FileItem.Name Like "*" & ".pdf" Then
              With fso
                Oldfile = SourceFolder.Path & "\" & FileItem.Name
                NewFile = SourceFolder.Path & "\" & .GetBaseName(SourceFolder) & ".pdf"
                NewFolder = "D:\Renamed\"                                      '<<< Change here
                If Not .FolderExists(NewFolder) then .CreateFolder(NewFolder)
              ' Upadate the file names
                .MoveFile Oldfile, NewFile
              ' Copy pdfs to new folder
                .CopyFile NewFile, NewFolder & .GetBaseName(NewFile) & ".pdf", False  ' False = no not overwrite files, True= overwrite files without warning
              End With
            End If
        Next
            If IncludeSubfolders Then
                For Each SubFolder In SourceFolder.SubFolders
                    ListFilesInFolder SubFolder.Path, False
                Next SubFolder
            End If
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fso = Nothing
End Sub

Let me know if it's still causing you any problems.

abousetta

The modifications in red above should check if the folder exists and if not then create a new folder called Renamed

abousetta