VBA - Loop through every file in folder and rename, save in destination folder.

[uvela]

Hello,

I'm trying to rename all files in a folder based on values in the file and then save them in a user selected folder.

Below is what I have so far. It is able to rename and save the file but I have to select the save folder through each loop.

Is there a way to select the destination folder once at the beginning and have the macro loop through every file in the folder to save and rename?

Function ChooseFolder1() As String
    Dim fldr As FileDialog
    Dim sItem As String

    Set fldr = Application.FileDialog(4)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    ChooseFolder1 = sItem
    Set fldr = Nothing
End Function

Sub payrollmacro1()

Dim wb As Workbook
Dim ws As Worksheet
Dim firstname As String
Dim lastname As String
Dim datefirst As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.GetFolder("C:\Users\Private\Documents\Projects\PayrollTimeSheets")

For Each objFile In objFolder.Files

        If objFile.Name Like "*Time-Card*" Then
       
        Set wb = Workbooks.Open(objFile.path)
       
        firstname = Workbooks(objFile.Name).Worksheets("Time Card").Range("C2")
        lastname = Workbooks(objFile.Name).Worksheets("Time Card").Range("B2")
       
        datefirst = Workbooks(objFile.Name).Worksheets("Time Card").Range("D2").Value
       
        wb.SaveAs Filename:=ChooseFolder1 & "\" & Format(datefirst, "yyyymmdd") & "-" & firstname & lastname & "-" & "TimeCard" & ".xlsx", FileFormat:=51
        wb.Close
End If    
       
Next objFile
End Sub

Any help would be appreciated. Thanks

 

[GWteB]

The code below will most likely do what you want. I've replaced your ChooseFolder1 function and added a ProperFolderPath function.
Hope this helps.

Public Function BrowseForFolderName(Optional ByVal argFolder As String = "") As String
    With Excel.Application.FileDialog(msoFileDialogFolderPicker)
        If VBA.CreateObject("Scripting.FileSystemObject").FolderExists(argFolder) Then
            .InitialFileName = ProperFolderPath(argFolder)
        Else
            .InitialFileName = VBA.Environ("userprofile") & "\Documents\"
        End If
        If .Show Then
            BrowseForFolderName = .SelectedItems(1)
        End If
    End With
End Function

Public Function ProperFolderPath(ByVal argPath As String) As String
    Do While VBA.Right(argPath, 1) = Excel.Application.PathSeparator
        argPath = VBA.Left(argPath, VBA.Len(argPath) - 1)
    Loop
    ProperFolderPath = argPath & Excel.Application.PathSeparator
End Function


Sub payrollmacro1()

    Dim wb As Workbook
    Dim firstname As String
    Dim lastname As String
    Dim datefirst As String
    Dim objFolder As Object
    Dim objFile As Object
    
    Dim FolderName As String
    FolderName = BrowseForFolderName("C:\Users\Private\Documents\Projects\PayrollTimeSheets")

    If VBA.Len(FolderName) > 0 Then

        Set objFolder = VBA.CreateObject("Scripting.FileSystemObject").GetFolder(FolderName)

        For Each objFile In objFolder.Files
            If objFile.Name Like "*Time-Card*" Then

                Set wb = Workbooks.Open(objFile.Path)
                With wb.Worksheets("Time Card")
                    firstname = .Range("C2")
                    lastname = .Range("B2")
                    datefirst = .Range("D2").Value
                End With
                wb.SaveAs Filename:=FolderName & "\" & Format(datefirst, "yyyymmdd") & "-" & firstname & lastname & "-" & "TimeCard" & ".xlsx", FileFormat:=51
                wb.Close

            End If
        Next objFile
    End If
End Sub

 

[uvela]

Appreciate the response GWteB. Unfortunately, the code isn't doing exactly what I need. I am also getting a 1004 error after the first file is looped through and the

wb.SaveAs Filename:=FolderName & "\" & Format(datefirst, "yyyymmdd") & "-" & firstname & lastname & "-" & "TimeCard" & ".xlsx", FileFormat:=5

line is highlighted as the issue.

The first dialogue box that shows up selects the folder in which the files to be renamed are in but does not allow me to select the destination of the save file.

I would like to, if possible, loop through every file in a selected OR a hardcoded folder where the word "Time-Card" is in the file name. From there I would like to rename the file based on the cell values in the workbook into a new user selected folder.

Is this possible?

Again, thanks in advance for any help.

 

[GWteB]

Be sure that the filename that is being composed on the line which is giving you an error is a valid filename.
I'll post back a revision of my code regarding your additional query shortly.

 

[GWteB]

See whether this macro does what you want. The two separate functions provided in my post #2 are dependencies, so still required to run the code below.
Note that if the destination folder already contains a file with exactly the same name as the file to be saved, the former will be overwritten unconditionally.

Sub payrollmacro1()

    Dim wb As Workbook
    Dim firstname As String
    Dim lastname As String
    Dim datefirst As String
    Dim objFolder As Object
    Dim objFile As Object
    
    Dim SrcFolderName As String, DestFolderName As String
    
    MsgBox "Determine source folder ...", vbOKOnly Or vbInformation
    SrcFolderName = BrowseForFolderName("C:\Users\Private\Documents\Projects\PayrollTimeSheets")
    If VBA.Len(SrcFolderName) > 0 Then
        
        MsgBox "Determine destination folder ...", vbOKOnly Or vbInformation
        DestFolderName = BrowseForFolderName(SrcFolderName)
        If VBA.Len(DestFolderName) > 0 Then
        
            Set objFolder = VBA.CreateObject("Scripting.FileSystemObject").GetFolder(SrcFolderName)
            For Each objFile In objFolder.Files
                If objFile.Name Like "*Time-Card*" Then
    
                    Set wb = Workbooks.Open(objFile.Path)
                    With wb.Worksheets("Time Card")
                        firstname = .Range("C2")
                        lastname = .Range("B2")
                        datefirst = .Range("D2").Value
                    End With
                    ' overwrite any existing file 
                    Excel.Application.DisplayAlerts = False
                    wb.SaveAs Filename:=DestFolderName & "\" & Format(datefirst, "yyyymmdd") & "-" & firstname & lastname & "-" & "TimeCard" & ".xlsx", FileFormat:=51
                    wb.Close
                    Excel.Application.DisplayAlerts = True
                End If
            Next objFile
        End If
    End If
End Sub

 

[uvela]

Thank you so much GWteB. The code worked perfectly. Much appreciated.

 

[GWteB]

Glad it's sorted and thanks for posting back