Help Needed for unique task

Shinho62

New Member
Joined
Mar 16, 2011
Messages
26
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>
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
How about something like this...

Code:
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
 
Upvote 0
How about something like this...

Code:
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
 
Upvote 0
How about something like this...

Code:
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
 
Upvote 0
Do you know which line threw the error.
 
Upvote 0
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...
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,501
Messages
6,114,010
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top