asked on
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