Option Explicit
Sub CopyWorkbook()
' modify path as required
Const PathName As String = "Z:\Report"
Dim SelFiles() As String
Dim Fn As String ' File name
Dim Sp() As String
If GetSelectedFiles(PathName, SelFiles) Then
Fn = NewFileName(SelFiles(0))
If Len(Fn) Then
Fn = WithSeparator(PathName) & Fn & ".xlsx"
FileCopy SelFiles(0), Fn
Workbooks.Open Fn
With Workbooks.Open(Fn)
Application.Calculation = xlCalculationAutomatic
Sp = Split(.Name, ".")
'add date
.Sheets("Avg Daily Vol").Range("A5").Value = _
Left(.Name, Len(.Name) - (Len(Sp(UBound(Sp))) + 1))
'increment MTD, QTD, YTD
.Sheets("Input").Range("B20").Value = _
.Sheets("Input").Range("B20").Value + 1
.Sheets("Input").Range("B21").Value = _
.Sheets("Input").Range("B21").Value + 1
.Sheets("Input").Range("B22").Value = _
.Sheets("Input").Range("B22").Value + 1
End With
'CloseThisWorkbook
Else
MsgBox "No valid file name was supplied.", _
vbCritical, "Can't rename"
End If
End If
End Sub
Private Function GetSelectedFiles(Pn As String, _
SelFiles() As String) _
As Boolean
' 0086 V 1.0
Dim FoD As FileDialog ' File Open Dialog
Dim SelItem As Variant ' Selected Item
Dim i As Long ' Index for SelFiles
Dim DefaultDate As Date
DefaultDate = Application.WorksheetFunction.WorkDay(Date, -2)
Set FoD = Application.FileDialog(msoFileDialogFilePicker)
With FoD
.Title = "Choose the workbook to copy"
.ButtonName = "Create Copy"
.Filters.Clear
.Filters.Add "Excel Files", "*.xls*", 1
.InitialFileName = WithSeparator(Pn) & _
Format(DefaultDate, "MMMM d yyyy") _
& ".xlsx"
.AllowMultiSelect = False
If .Show Then
For Each SelItem In .SelectedItems
ReDim Preserve SelFiles(i)
SelFiles(i) = SelItem
i = i + 1
Next SelItem
GetSelectedFiles = True
End If
End With
Set FoD = Nothing
End Function
Private Function NewFileName(Ffn As String) As String
Dim Sp() As String
Dim Fn As String ' File name (old)
Dim Fnn As String ' File name New
Dim Fd As Date ' File date
Sp = Split(Ffn, "\")
Fn = Split(Sp(UBound(Sp)), ".")(0)
If IsDate(Fn) Then
Fd = Application.WorksheetFunction.WorkDay(CDate(Fn), 1)
Fnn = Format(Fd, "mmmm d yyyy")
Fn = Fn
End If
NewFileName = InputBox("Copying the workbook" & vbCr & _
"of " & Fn & Format(CDate(Fn), " (dddd)") & vbCr & _
"Please confirm or enter " & _
"the copy's file name." & vbCr & vbCr & _
IIf(IsDate(Fn), "(" & Format(Fd, "dddd") & _
")", ""), "New file name", Fnn)
End Function
Private Function WithSeparator(ByVal PathName As String, _
Optional ByVal RemoveExisting As Boolean) _
As String
Do While Right(PathName, 1) = Application.PathSeparator
PathName = Left(PathName, Len(PathName) - 1)
Loop
WithSeparator = PathName & IIf(RemoveExisting, "", _
Application.PathSeparator)
End Function
'Sub CloseWorkbook()
' SetAppScreen False
' ThisWorkbook.Close SaveChanges:=xlDoNotSaveChanges
'End Sub
Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.
When asked, what has been your best career decision?
Deciding to stick with EE.
Being involved with EE helped me to grow personally and professionally.
Connect with Certified Experts to gain insight and support on specific technology challenges including:
We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE