Help Needed for unique task

[Shinho62]

Good evening Ladies & Gentlemen

I have been asked by a friend if I could help with an issue she faces on a weekly basis with excel workbooks

Basically on the Monday morning of each week, she has to open a folder and view excel workbooks contained within
that has around 80 - 150 workbooks at any one time, copy all workbooks to another folder

she then has to rename said workbooks individually to a Name (normally a customer), and then the date of that Monday for example
she renamed 86 excel workbooks from Briggs 22 July 2019 to Briggs 29 July 2019

all the workbooks start off with different names for example

Briggs

22 July 2019​

Jones

22 July 2019
David

22 July 2019
Wright

22 July 2019

is there a script or macro via excel that can look at the folder (even browse to it from within the script); and then rename the last portion of the file name to the date needed

I thought that maybe having a reference point on a sheet in cell A1 that reads Briggs

and a script that asks for the folder location (browse to); then asks for the date and off it goes opening and saving the workbook, based on the name in cell A1 in sheet "NewDate"

and at the end of the work, pops a message up saying how many workbooks it has renamed, so she can check the folder to ensure none are missed

The reason i am asking is this is well beyond my skill level, and so i reach out to this forum for advice and or guidance

Thanks in advance
​

​

_{^{<strike>
</strike>}}​

 

[rccharles]

You could do most or all of this in a scripting language like python. Search rename file python. Search list file in a folder python.

example:
https://www.geeksforgeeks.org/rename-multiple-files-using-python/

 

[igold]

How about something like this...

Sub RenameSaveWorkbooks()


    Dim wb As Workbook
    Dim myPath As String, myFile As String, myExtension As String
    Dim FldrPicker As FileDialog
    Dim OldName As String, NewName As String, NewDate As String, NewPath As String
    Dim n As Integer, ct As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False


    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
      .Title = "Select the Folder With Old Workbooks"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NoPick
        myPath = .SelectedItems(1) & "\"
    End With


NoPick:
    myPath = myPath
    If myPath = "" Then GoTo CleanUp
    
    myExtension = "*.xls*"
    myFile = Dir(myPath & myExtension)
    NewDate = InputBox("Please Enter the New Date For Saving")
    NewPath = InputBox("Please Enter the New Folder Path For Saving")
    If Not Right(NewPath, 1) = "\" Then NewPath = NewPath & "\"


    Do While myFile <> ""
        Set wb = Workbooks.Open(Filename:=myPath & myFile)
        DoEvents
        With ActiveWorkbook
            OldName = .Name
            n = InStr(OldName, " ")
            OldName = Left(OldName, n - 1)
            NewName = OldName & " " & NewDate
            .SaveAs Filename:=NewPath & NewName & ".xls"
            ct = ct + 1
        End With
        wb.Close SaveChanges:=True
        DoEvents
        myFile = Dir
    Loop


    MsgBox "Operation Complete!" & vbNewLine & vbNewLine & _
        ct & " Workbooks were renamed and saved to your new location."


CleanUp:
    Application.EnableEvents = True
    Application.ScreenUpdating = True


End Sub

 

[Shinho62]

How about something like this...

Sub RenameSaveWorkbooks()


    Dim wb As Workbook
    Dim myPath As String, myFile As String, myExtension As String
    Dim FldrPicker As FileDialog
    Dim OldName As String, NewName As String, NewDate As String, NewPath As String
    Dim n As Integer, ct As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False


    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
      .Title = "Select the Folder With Old Workbooks"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NoPick
        myPath = .SelectedItems(1) & "\"
    End With


NoPick:
    myPath = myPath
    If myPath = "" Then GoTo CleanUp
    
    myExtension = "*.xls*"
    myFile = Dir(myPath & myExtension)
    NewDate = InputBox("Please Enter the New Date For Saving")
    NewPath = InputBox("Please Enter the New Folder Path For Saving")
    If Not Right(NewPath, 1) = "\" Then NewPath = NewPath & "\"


    Do While myFile <> ""
        Set wb = Workbooks.Open(Filename:=myPath & myFile)
        DoEvents
        With ActiveWorkbook
            OldName = .Name
            n = InStr(OldName, " ")
            OldName = Left(OldName, n - 1)
            NewName = OldName & " " & NewDate
            .SaveAs Filename:=NewPath & NewName & ".xls"
            ct = ct + 1
        End With
        wb.Close SaveChanges:=True
        DoEvents
        myFile = Dir
    Loop


    MsgBox "Operation Complete!" & vbNewLine & vbNewLine & _
        ct & " Workbooks were renamed and saved to your new location."


CleanUp:
    Application.EnableEvents = True
    Application.ScreenUpdating = True


End Sub

thanks will give it a go

 

[Shinho62]

How about something like this...

Sub RenameSaveWorkbooks()


    Dim wb As Workbook
    Dim myPath As String, myFile As String, myExtension As String
    Dim FldrPicker As FileDialog
    Dim OldName As String, NewName As String, NewDate As String, NewPath As String
    Dim n As Integer, ct As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False


    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
      .Title = "Select the Folder With Old Workbooks"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NoPick
        myPath = .SelectedItems(1) & "\"
    End With


NoPick:
    myPath = myPath
    If myPath = "" Then GoTo CleanUp
    
    myExtension = "*.xls*"
    myFile = Dir(myPath & myExtension)
    NewDate = InputBox("Please Enter the New Date For Saving")
    NewPath = InputBox("Please Enter the New Folder Path For Saving")
    If Not Right(NewPath, 1) = "\" Then NewPath = NewPath & "\"


    Do While myFile <> ""
        Set wb = Workbooks.Open(Filename:=myPath & myFile)
        DoEvents
        With ActiveWorkbook
            OldName = .Name
            n = InStr(OldName, " ")
            OldName = Left(OldName, n - 1)
            NewName = OldName & " " & NewDate
            .SaveAs Filename:=NewPath & NewName & ".xls"
            ct = ct + 1
        End With
        wb.Close SaveChanges:=True
        DoEvents
        myFile = Dir
    Loop


    MsgBox "Operation Complete!" & vbNewLine & vbNewLine & _
        ct & " Workbooks were renamed and saved to your new location."


CleanUp:
    Application.EnableEvents = True
    Application.ScreenUpdating = True


End Sub

Hi thanks for the above, i ran the code and it asked for the folder location, which was good, it then asked for the "new date for saving", which i entered, it asked the same for each file in the folder (only 4 excel files); it then gave an error code

run-time error '1004':

Application-Define or Object-Define error

 

[igold]

Do you know which line threw the error.

 

[Shinho62]

Do you know which line threw the error.

Hi, was unsure what you were asking me to do, but then figured out how to step through the code
it stopped at line 42 Col 1

 

[igold]

How about the actual line of code. Your line 42 is not necessarily my line 42...

Also was this the entire error message

run-time error '1004':

Application-Define or Object-Define error

or was there additional info provided...