jfrank14
asked on
Excel Macro saving to a specific location help
Hi All,
Need some help on this one please.
Basically I have a macro that opens a file that is 2 business days prior, changes the date in the sheet to 1 previous business day, and then saves as the previous business day.
the issue is, it just saves the new file in the root. I need some help getting it to save in a specific location based on the month and day in the filename.
Example:
the file will be: "December 20 2013.xlsx"
I would like this to be saved under 2013\December\
Here is my code:
Thanks!
Need some help on this one please.
Basically I have a macro that opens a file that is 2 business days prior, changes the date in the sheet to 1 previous business day, and then saves as the previous business day.
the issue is, it just saves the new file in the root. I need some help getting it to save in a specific location based on the month and day in the filename.
Example:
the file will be: "December 20 2013.xlsx"
I would like this to be saved under 2013\December\
Here is my code:
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 SubThanks!
ASKER
right, i would need a sub folder existence verification first.
then place the file accordingly.
the value displayed in the input box is the filename of which it will be saved as. the reason its an input box is in the event there is a holiday, etc, and you need to manually override the filename which you will be saving as.
so basically, whatever is in that input box should be broken down to create the folder/check folder structure.
then place the file accordingly.
the value displayed in the input box is the filename of which it will be saved as. the reason its an input box is in the event there is a holiday, etc, and you need to manually override the filename which you will be saving as.
so basically, whatever is in that input box should be broken down to create the folder/check folder structure.
Exactly. Right now, does the input box display "z:\reports\2013\december\
If the first, then you can split by the '\', then verify if 2 exists, then 2\3, then 2\3\4. Once all have been confirmed then you can safe the file in 2\3\4\5. A simple function which will verify the existence and create a new folder if not will work, then just call it from a loop:
If the first, then you can split by the '\', then verify if 2 exists, then 2\3, then 2\3\4. Once all have been confirmed then you can safe the file in 2\3\4\5. A simple function which will verify the existence and create a new folder if not will work, then just call it from a loop:
for i=1 to length(split)-1
verifyExistence pathSplit(i)
next iASKER
Input just says:
December 20 2013
December 20 2013
Then you will have to trace back in the code to display the entire path (for now) in the input box. Once you can see you have the correct path, you can change back to just the date but this will be a convenient location to verify that the rest of your code functions correctly. Then you can modify the save function to confirm the path exists before trying to save to that path.
ASKER
Hi,
can you please help me in getting this to what i need? Can you please explain what to change/add?
thanks.
can you please help me in getting this to what i need? Can you please explain what to change/add?
thanks.
Right before FileCopy on line 16, call this sub:
Then you can call checkFolder just before CopyFile with the full path name. That should solve your problem (I hope) - You will need to verify the syntax is correct, but it should be.
sub checkFolder(pathName)
dim folders as string
folders = split(pathName)
for i=1 to len(folders)-1
dim curPath as string
for j=0 to i
curPath = curPath + folders(j) + "\"
if dir (curPath, vbDirectory) = vbNullString then
mkDir curPath
end
next j
next i
end subThen you can call checkFolder just before CopyFile with the full path name. That should solve your problem (I hope) - You will need to verify the syntax is correct, but it should be.
ASKER
getting a compile error.
"expected sub, function, or property"
I tried:
Dim checkfolder() As String
Call checkfolder (pathName)
checkfolder (pathName)
and i added your sub per above.
"expected sub, function, or property"
I tried:
Dim checkfolder() As String
Call checkfolder (pathName)
checkfolder (pathName)
and i added your sub per above.
As I said you will need to check the syntax. It is possible that the checkFolder function needs to be declared before it is called. That part of the coding you will need to work out for yourself, as I have no copy of Excel here, and am only passing on ideas and thoughts to help you get it working. You would not be using Dim checkfolder() as string but rather just checkFolder pathname. I don't think VBA needs brackets around a function call, and I am not sure about the syntax of declaring a function. Maybe you need to use
Sub checkFolder(pathName as string)
...
end sub
Sub checkFolder(pathName as string)
...
end sub
ASKER
hightlighting Sub checkfolder(pathName As String)
saying compile error: variable not defined
current code:
saying compile error: variable not defined
current code:
Option Explicit
Sub CopyWorkbook()
' modify path as required
' Const PathName As String = "Z:\Reports"
Dim SelFiles() As String
'Dim checkfolder() 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
FileCopy SelFiles(0), Fn
checkfolder (pathName)
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 checkfolder(pathName As String)
Dim folders As String
folders = Split(pathName)
For i = 1 To Len(folders) - 1
Dim curPath As String
For j = 0 To i
curPath = curPath + folders(j) + "\"
If Dir(curPath, vbDirectory) = vbNullString Then
MkDir curPath
End
Next j
Next i
End Sub
'Sub CloseWorkbook()
' SetAppScreen False
' ThisWorkbook.Close SaveChanges:=xlDoNotSaveChanges
'End Sub
Ok. Move the sub location to the top of the file, above the copyWorkbook sub declaration. Also move the call to the checkFolder sub up one line, to be called BEFORE the copy file occurs. Also check to make sure that pathName is the complete path you will be sending the file to. If it is not then you will need to make sure you are passing in the correct parameter.
ASKER
hi thanks for your reply. so i did what you mentioned above.
pathname is "the correct path" , but the filename or "fn" actually should be broken up when I think about it.
pathname = "Z:\Reports"
fn = "December 20 2013"
so really i'd want fn broken out so that the folder would be:
Z:\Reports\2013\December
within that path would be the December 20 2013 file.
pathname is "the correct path" , but the filename or "fn" actually should be broken up when I think about it.
pathname = "Z:\Reports"
fn = "December 20 2013"
so really i'd want fn broken out so that the folder would be:
Z:\Reports\2013\December
within that path would be the December 20 2013 file.
So the next step would be to parse out the file name to create the correct path. split(fn," ")(0) will give you the month, and split(fn," ")(2) will give you the year. Add those to the path to get the correct saving path (z:\reports\2013\december\
ASKER
sorry for the late reply. i was traveling for the holidays.
so here is what i have so far. when i run the code, i get "variable not defined" highlighting:
Sub checkFolder(pathName As String)
Also can you help with the split above? where should i be putting that?
Here is my full code. Any ideas?
so here is what i have so far. when i run the code, i get "variable not defined" highlighting:
Sub checkFolder(pathName As String)
Also can you help with the split above? where should i be putting that?
Here is my full code. Any ideas?
Option Explicit
Sub checkFolder(pathName As String)
Dim folders As String
folders = Split(pathName)
For i = 1 To Len(folders) - 1
Dim curPath As String
For j = 0 To i
curPath = curPath + folders(j) + "\"
If Dir(curPath, vbDirectory) = vbNullString Then
MkDir curPath
End
Next j
Next i
End Sub
Sub CopyWorkbook()
' modify path as required
Const pathName As String = "H:\Futures\Macros\F&O Report"
Dim SelFiles() As String
Dim Fn As String ' File name
Dim Sp() As String
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(pathName, SelFiles) Then
Fn = NewFileName(SelFiles(0))
If Len(Fn) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = Fn
.Range("J11").Value = pathName
End With
.Save
End With
If Len(Fn) Then
Fn = WithSeparator(pathName) & Fn & ".xlsx"
'insert new code
'
checkFolder (pathName)
'
'end new code
FileCopy SelFiles(0), Fn
'Workbooks.Open Fn
With Workbooks.Open(Fn)
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 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 CopyPaste()
Dim Wb As Workbook
Dim Fn As String
If Len(Fn) Then
MsgBox ("" & Fn & "")
'Fn = ThisWorkbook.Sheets("F&O Daily").Range("A11").Value
Set Wb = Workbooks.Add(Fn)
CopyRanges
Else
MsgBox "No file name"
End If
End Sub
Private Sub CopyRanges()
Dim WsS As Worksheet ' S = Source
Dim WsT As Worksheet ' T = Target
Set WsS = Sheets("Input")
Set WsT = Sheets("Avg Daily Vol")
CopyInput WsS, WsT
End Sub
Private Sub CopyInput(WsS As Worksheet, WsT As Worksheet)
' Copy from Input!B8:O11 To To Avg Daily Vol!G5:T8
WsS.Range("B8:O11").Copy Destination:=WsT.Range("G5")
End SubASKER
hi - any luck?
I do not own Microsoft Office at all, so I am unable to write your macro for you. The best I am able to do is advise you on how to solve the problem, and leave the actual mechanics of it to you. I believe that I have done this, so now it is up to you to finish the program by ensuring that the save folder exists before saving the file to that folder. I am assuming that you were the writer of the macro and as such that you have some experience in VBA.
If this is not the case then I recommend that you ask the question again and find someone who is both willing and able to write your software solutions for you. I see my role as being here to give advice and direction to enable you to learn and improve your coding skills.
Sincerely,
Geoff
If this is not the case then I recommend that you ask the question again and find someone who is both willing and able to write your software solutions for you. I see my role as being here to give advice and direction to enable you to learn and improve your coding skills.
Sincerely,
Geoff
Is this what you want?
Option Explicit
Sub checkFolder(pathName As String)
Dim folders() As String
Dim i As Integer, j As Integer
folders = Split(pathName, "\")
For i = 1 To UBound(folders)
Dim curPath As String
For j = 0 To i
curPath = curPath & folders(j) & "\"
If Dir(curPath, vbDirectory) = vbNullString Then
MkDir curPath
End If
Next j
Next i
End Sub
Sub CopyWorkbook()
Dim pathName As String
Dim SelFiles() As String
Dim Filename() As String
Dim Fn As String ' File name
Dim Sp() As String
pathName = "H:\Futures\Macros\F&O Report" ' modify path as required
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(pathName, SelFiles) Then
Fn = NewFileName(SelFiles(0))
If Len(Fn) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = Fn
.Range("J11").Value = pathName
End With
.Save
End With
If Len(Fn) Then
Fn = WithSeparator(pathName) & Fn & ".xlsx"
'insert new code
'
Filename = Split(Fn, " ")
pathName = pathName & "\" & Filename(0) & "\" & Left(Filename(2), 4)
checkFolder (pathName)
'
'end new code
FileCopy SelFiles(0), Fn
'Workbooks.Open Fn
With Workbooks.Open(Fn)
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 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 CopyPaste()
Dim Wb As Workbook
Dim Fn As String
If Len(Fn) Then
MsgBox ("" & Fn & "")
'Fn = ThisWorkbook.Sheets("F&O Daily").Range("A11").Value
Set Wb = Workbooks.Add(Fn)
CopyRanges
Else
MsgBox "No file name"
End If
End Sub
Private Sub CopyRanges()
Dim WsS As Worksheet ' S = Source
Dim WsT As Worksheet ' T = Target
Set WsS = Sheets("Input")
Set WsT = Sheets("Avg Daily Vol")
CopyInput WsS, WsT
End Sub
Private Sub CopyInput(WsS As Worksheet, WsT As Worksheet)
' Copy from Input!B8:O11 To To Avg Daily Vol!G5:T8
WsS.Range("B8:O11").Copy Destination:=WsT.Range("G5")
End Sub
This would be my recommendation though:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub Demo()
Dim strDestination As String
Dim wb As Workbook
Dim sp() As String, fn() As String
strDestination = "Z:\Reports"
If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
Set wb = Workbooks.Open(SelectFile)
With wb
sp = Split(.Name, ".")
fn = Split(.Name, " ")
strDestination = strDestination & fn(0) & "\" & Left(fn(2), 4) & "\"
'add date
.Sheets("Avg Daily Vol").Range("A5").Value = Left(.Name, Len(.Name) - (Len(sp(1)) + 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
MakeSureDirectoryPathExists strDestination
' MyMkDir strDestination ' or this, if you don't want to use API
wb.SaveAs (strDestination & wb.Name)
End Sub
Public Function SelectFile() As String
' 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
Dim SelFiles As String
DefaultDate = Application.WorksheetFunction.WorkDay(Date, -2)
Set FoD = Application.FileDialog(msoFileDialogFilePicker)
With FoD
.Title = "Choose the workbook to copy"
.ButtonName = "Select"
.Filters.Clear
.Filters.Add "Excel Files", "*.xls*", 1
.InitialFileName = Format(DefaultDate, "MMMM d yyyy") & ".xlsx"
.AllowMultiSelect = False
If .Show Then
SelectFile = .SelectedItems(1)
End If
End With
Set FoD = Nothing
End Function
Public Sub MyMkDir(sPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
Next i
End If
End Sub
You can check if a folder exists in a couple of lines
Dim fso As Object
Set fso = CreateObject("Scripting.Fi
MsgBox fso.FolderExists("C:\Test\
Dim fso As Object
Set fso = CreateObject("Scripting.Fi
MsgBox fso.FolderExists("C:\Test\
ASKER
Hi MacroShadow,
Thanks for your reply. I tried your first suggested code as the rest of my code works great, its just trying to implement the new feature that i'm having issues with. To summarize again, I want to save the file under a specific structure. I.e if the file name is December 3 2013, I want to save it under the folder 2013, then under the folder December. If none of these exist, Create them.
I get a break on Line 14:
If Dir(curPath, vbDirectory) = vbNullString Then
"Run time rror '52'
bad file name or number"
highlighting the line, looks like curPath = H:\Futures\H:\
vbDirectory = 16
vbNullString = ""
What could be the issue here?
Thanks for your reply. I tried your first suggested code as the rest of my code works great, its just trying to implement the new feature that i'm having issues with. To summarize again, I want to save the file under a specific structure. I.e if the file name is December 3 2013, I want to save it under the folder 2013, then under the folder December. If none of these exist, Create them.
I get a break on Line 14:
If Dir(curPath, vbDirectory) = vbNullString Then
"Run time rror '52'
bad file name or number"
highlighting the line, looks like curPath = H:\Futures\H:\
vbDirectory = 16
vbNullString = ""
What could be the issue here?
Delete the check folder routine it is full of errors!
Replace it with this:
Replace it with this:
Public Sub MyMkDir(sPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
Next i
End If
End SubcheckFolder (pathName)MyMkDir strDestinationASKER
hi!
did that, but changed:
MyMkDir strDestination
to:
MyMkDir pathName
still getting the same error above:
If Dir(sCurDir, vbDirectory) = vbNullString Then
"Run time error '52'
bad file name or number"
highlighting the line, looks like sCurDir = H:\Futures\Macros\F&ORepor
vbDirectory = 16
vbNullString = ""
maybe it shouldnt be adding aDirs after it? Seems likes its adding the drive letter (H:\) again.
What could be the issue here?
did that, but changed:
MyMkDir strDestination
to:
MyMkDir pathName
still getting the same error above:
If Dir(sCurDir, vbDirectory) = vbNullString Then
"Run time error '52'
bad file name or number"
highlighting the line, looks like sCurDir = H:\Futures\Macros\F&ORepor
vbDirectory = 16
vbNullString = ""
maybe it shouldnt be adding aDirs after it? Seems likes its adding the drive letter (H:\) again.
What could be the issue here?
I can't reproduce the error.
You can try using this api instead of the MyMkDir sub.
Add this in the first line of the module (under the options (explicit etc.) if you have any):
then change
You can try using this api instead of the MyMkDir sub.
Add this in the first line of the module (under the options (explicit etc.) if you have any):
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Longthen change
MyMkDir pathNameMakeSureDirectoryPathExists pathNameASKER
hey - so i did that, no errors and completes.
however, it doesn't create the folders!
per ID: 39840157
however, it doesn't create the folders!
per ID: 39840157
Works for me! Do you have write permissions to the destination?
Is this your pathName: "H:\Futures\Macros\F&ORepo
Is this your pathName: "H:\Futures\Macros\F&ORepo
ASKER
I do have write permissions, it saves the new file there, but in the root. doesnt create the sub folders like it should.
Right, it's : H:\Futures\Macros\F&O Report
Right, it's : H:\Futures\Macros\F&O Report
It needs the closing slash i.e. H:\Futures\Macros\F&O Report\
ASKER
tried that too. no errors, did all the work but did not create the folder directories.
here is what i have:
here is what i have:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
'
'Public Sub MyMkDir(sPath As String)
' Dim iStart As Integer
' Dim aDirs As Variant
' Dim sCurDir As String
' Dim i As Integer
'
' If sPath <> "" Then
' aDirs = Split(sPath, "\")
' If Left(sPath, 2) = "\\" Then
' iStart = 3
' Else
' iStart = 1
' End If
' sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
' For i = iStart To UBound(aDirs)
' sCurDir = sCurDir & aDirs(i) & "\"
' If Dir(sCurDir, vbDirectory) = vbNullString Then
' MkDir sCurDir
' End If
' Next i
' End If
'End Sub
Sub CopyWorkbook()
Dim pathName As String
Dim SelFiles() As String
Dim Filename() As String
Dim Fn As String ' File name
Dim Sp() As String
' modify path as required
pathName = "H:\Futures\Macros\F&O Report\"
If Right(pathName, 1) <> "\" Then pathName = pathName & "\"
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(pathName, SelFiles) Then
Fn = NewFileName(SelFiles(0))
If Len(Fn) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = Fn
.Range("J11").Value = pathName
End With
.Save
End With
If Len(Fn) Then
Fn = WithSeparator(pathName) & Fn & ".xlsx"
'insert new code
'
' Filename = Split(Fn, " ")
' pathName = pathName & "\" & Filename(0) & "\" & Left(Filename(2), 4)
MakeSureDirectoryPathExists pathName
'
'end new code
FileCopy SelFiles(0), Fn
'Workbooks.Open Fn
With Workbooks.Open(Fn)
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 If
End Sub
Add a message box after line 43, does it show?
ASKER
hi , yes it does show.
I don't know. It works fine by me.
ASKER
I tried changing the path to desktop and same thing. it creates the file (as it did before), no errors, get the MSGBOX, but doesnt create the directories. could it be the dll?
imagehlp.dll ?
maybe its not properly registered, or i dont have it on my computer?
the pathname is the root location.
i dont get which part of the code breaks down the filename into the sub folders?
Fn = WithSeparator(pathName) & Fn & ".xlsx"
so I need to take the Fn and break it down into folders, check if the folder exists, then create if they dont.
so i should see:
PathName \ Fn (broken down)
PathName\2014\February\ (file in here).
imagehlp.dll ?
maybe its not properly registered, or i dont have it on my computer?
the pathname is the root location.
i dont get which part of the code breaks down the filename into the sub folders?
Fn = WithSeparator(pathName) & Fn & ".xlsx"
so I need to take the Fn and break it down into folders, check if the folder exists, then create if they dont.
so i should see:
PathName \ Fn (broken down)
PathName\2014\February\ (file in here).
Last try ;)
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub CopyWorkbook()
Dim pathName As String
Dim SelFiles() As String
Dim Filename() As String
Dim Fn As String ' File name
Dim Sp() As String
' modify path as required
pathName = "H:\Futures\Macros\F&O Report\"
If Right(pathName, 1) <> "\" Then pathName = pathName & "\"
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(pathName, SelFiles) Then
Fn = NewFileName(SelFiles(0))
If Len(Fn) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = Fn
.Range("J11").Value = pathName
End With
.Save
End With
If Len(Fn) Then
Fn = WithSeparator(pathName) & Fn & ".xlsx"
'insert new code
'
Filename = Split(Fn, " ")
pathName = pathName & _
IIf(Right(pathName, 1) = "\", "", "\") & _
Filename(0) _
& "\" & _
Left(Filename(2), 4)
MakeSureDirectoryPathExists pathName
'
'end new code
FileCopy SelFiles(0), Fn
'Workbooks.Open Fn
With Workbooks.Open(Fn)
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 If
End Sub
Here's the explanation:
Ok, let's break it down.
1.
So for your example: December 20 2013.xlsx this would be the data stored in the array:
Filename(0) = "December"
Filename(1) = "20"
Filename(2) = "2013.xlsx"
2.
In this line we set the path as follows:
Viola, the full path should be:
H:\Futures\Macros\F&O Report\December\2013
Ok, let's break it down.
1.
Filename = Split(Fn, " ")So for your example: December 20 2013.xlsx this would be the data stored in the array:
Filename(0) = "December"
Filename(1) = "20"
Filename(2) = "2013.xlsx"
2.
pathName = pathName & _
IIf(Right(pathName, 1) = "\", "", "\") & _
Filename(0) _
& "\" & _
Left(Filename(2), 4)In this line we set the path as follows:
pathName = pathName & _IIf(Right(pathName, 1) = "\", "", "\") & _Filename(0) _& "\" & _Left(Filename(2), 4)Viola, the full path should be:
H:\Futures\Macros\F&O Report\December\2013
ASKER
OK cool.
the end result should be:
H:\Futures\Macros\F&O Report\2013\December
However, in just trying to get the above to work i'm still having issues here. I copied and pasted exactly what you had above and ran the code. it adds the file, just doesnt create the sub directories and place it in there.
it addes the file into the root.
what could be going on here? it's working for you and not me..
what does: "imagehlp.dll" do?
the end result should be:
H:\Futures\Macros\F&O Report\2013\December
However, in just trying to get the above to work i'm still having issues here. I copied and pasted exactly what you had above and ran the code. it adds the file, just doesnt create the sub directories and place it in there.
it addes the file into the root.
what could be going on here? it's working for you and not me..
what does: "imagehlp.dll" do?
the end result should be:This will do it:
H:\Futures\Macros\F&O Report\2013\December
pathName = pathName & _
IIf(Right(pathName, 1) = "\", "", "\") & _
Left(Filename(2), 4) _
& "\" & _
Filename(0)imagehlp.dll is a system dll, if you have Windows you have it!
If you want help debugging please upload a sample file.
ASKER
Interesting. So I changed the code per the above, and I noticed a change. It now creates a folder but is naming the folder the DAY.
Example, I created 3 files:
January 3 2014
January 6 2014
It created two empty folders in the root:
3
6
However, the file is still in the root.
Getting closer it seems.
Here is what I have now:
Example, I created 3 files:
January 3 2014
January 6 2014
It created two empty folders in the root:
3
6
However, the file is still in the root.
Getting closer it seems.
Here is what I have now:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub CopyWorkbook()
Dim pathName As String
Dim SelFiles() As String
Dim Filename() As String
Dim Fn As String ' File name
Dim Sp() As String
' modify path as required
pathName = "H:\Futures\Macros\F&O Report\"
If Right(pathName, 1) <> "\" Then pathName = pathName & "\"
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(pathName, SelFiles) Then
Fn = NewFileName(SelFiles(0))
If Len(Fn) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = Fn
.Range("J11").Value = pathName
End With
.Save
End With
If Len(Fn) Then
Fn = WithSeparator(pathName) & Fn & ".xlsx"
'insert new code
'
Filename = Split(Fn, " ")
' pathName = pathName & _
' IIf(Right(pathName, 1) = "\", "", "\") & _
' Filename(0) _
' & "\" & _
' Left(Filename(2), 4)
pathName = pathName & _
IIf(Right(pathName, 1) = "\", "", "\") & _
Left(Filename(2), 4) _
& "\" & _
Filename(0)
MakeSureDirectoryPathExists pathName
'
'end new code
FileCopy SelFiles(0), Fn
'Workbooks.Open Fn
With Workbooks.Open(Fn)
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 If
End SubASKER
see attached sample
F-O-Report-sample.xlsm
F-O-Report-sample.xlsm
Your example doesn't help with out the data file.
ASKER
Try this:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub CopyWorkbook()
Dim strDestinationPath As String
Dim SelFiles() As String
Dim arrFilename() As String
Dim strFilename As String
Dim strSourcePath As String ' File name
Dim Sp() As String
Dim fso As Object
' modify path as required
strDestinationPath = "C:\Users\MacroShadow\Desktop\EE Demo\New"
If Right(strDestinationPath, 1) <> "\" Then strDestinationPath = strDestinationPath & "\"
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(strDestinationPath, SelFiles) Then
strFilename = Right(SelFiles(0), Len(SelFiles(0)) - InStrRev(SelFiles(0), "\"))
strSourcePath = NewFileName(strFilename)
If Len(strSourcePath) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = strSourcePath
.Range("J11").Value = strDestinationPath
End With
.Save
End With
If Len(strSourcePath) > 0 Then
arrFilename = Split(strFilename, "-")
strDestinationPath = strDestinationPath & _
IIf(Right(strDestinationPath, 1) = "\", "", "\") & _
Left(arrFilename(2), 4) _
& "\" & _
arrFilename(0) & "\"
MakeSureDirectoryPathExists strDestinationPath
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile SelFiles(0), strDestinationPath, True
Set fso = Nothing
'Workbooks.Open strSourcePath
With Workbooks.Open(strDestinationPath & "\" & strFilename)
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 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(Left(Ffn, (InStrRev(Ffn, ".", -1, vbTextCompare) - 1)), "-")
Fn = MonthNumber(Sp(0)) & "-" & Sp(1) & "-" & Sp(2)
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 CopyPaste()
Dim strSourcePathame As String, Report As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wbForCopy As Workbook
Set Report = ActiveWorkbook
strSourcePathame = Report.Worksheets(1).Range("A11").Text & ".xlsx"
Set wbForCopy = IsOpen(strSourcePathame)
If Not wbForCopy Is Nothing Then
Set ws1 = wbForCopy.Sheets("Input")
Set ws2 = wbForCopy.Sheets("Avg Daily Vol")
'MsgBox "Good, file opened."
ws1.Range("B8:O11").Copy
ws2.Range("G5").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'MsgBox "Input->Avg Daily Vol values pasted successfully!"
'Second set of copy/paste
Set ws3 = wbForCopy.Sheets("Totals")
'MsgBox "Good, file opened."
ws1.Range("B15:O17").Copy
ws3.Range("I5:V7").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
MsgBox "Values pasted successfully!"
Else
MsgBox "Today's report is currently not opened."
End If
End Sub
Function IsOpen(wbname As String) As Workbook
Dim Wb As Workbook
For Each Wb In Application.Workbooks
If Wb.Name = wbname Then
'MsgBox "Found open workbook"
Set IsOpen = Wb
Exit For
End If
Next Wb
End Function
Private Function GetWorkbook(Wn As String) As Workbook
Dim Wb As Workbook
Dim Sp() As String
Sp = Split(Wn, "\")
Debug.Print Sp(UBound(Sp))
On Error Resume Next
Set GetWorkbook = Workbooks(Sp(UBound(Sp)))
If Err Then
Set GetWorkbook = Workbooks.Open(Wn)
End If
End Function
Private Function MonthNumber(strMonName As String) As Integer
Dim strHold As String
Dim strMonth As String
Dim intMonth As Integer
strMonName = UCase(strMonName)
strMonth = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
strHold = Left(strMonName, 3)
intMonth = InStr(strMonth, strHold)
MonthNumber = intMonth \ 3 + 1
End FunctionASKER
subscript out of range on line 115:
Fn = MonthNumber(Sp(0)) & "-" & Sp(1) & "-" & Sp(2)
Fn = MonthNumber(Sp(0)) & "-" & Sp(1) & "-" & Sp(2)
Works fine for me, it should as well for you unless the data files names are not like the one you posted (January-2-2013.xlsx).
ASKER
im sorry, that was a type on my end.
file name should be:
December 31 2013.xlsx
no dashes, spaces.
can you please help me ammend? apologies for this.
file name should be:
December 31 2013.xlsx
no dashes, spaces.
can you please help me ammend? apologies for this.
Change line 114-115 to:
Sp = Split(Left(Ffn, (InStrRev(Ffn, ".", -1, vbTextCompare) - 1)), "-")
Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)ASKER
thanks.
subscript out of range on:
Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)
trying to use this file:
should be "January 1 2014.xlsx"
when i upload it here, experts adds the dashes.
January-1-2014.xlsx
subscript out of range on:
Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)
trying to use this file:
should be "January 1 2014.xlsx"
when i upload it here, experts adds the dashes.
January-1-2014.xlsx
Tested and working. Haven't checked if expected changes were made to the file, but the file does get copied to the correct directory.
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub CopyWorkbook()
Dim strDestinationPath As String
Dim SelFiles() As String
Dim arrFilename() As String
Dim strFilename As String
Dim strSourcePath As String ' File name
Dim Sp() As String
Dim fso As Object
' modify path as required
strDestinationPath = "C:\Users\MacroShadow\Desktop\EE Demo\New"
If Right(strDestinationPath, 1) <> "\" Then strDestinationPath = strDestinationPath & "\"
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(strDestinationPath, SelFiles) Then
strFilename = Right(SelFiles(0), Len(SelFiles(0)) - InStrRev(SelFiles(0), "\"))
strSourcePath = NewFileName(strFilename)
If Len(strSourcePath) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = strSourcePath
.Range("J11").Value = strDestinationPath
End With
.Save
End With
If Len(strSourcePath) > 0 Then
arrFilename = Split(strFilename, " ")
strDestinationPath = strDestinationPath & _
IIf(Right(strDestinationPath, 1) = "\", "", "\") & _
Left(arrFilename(2), 4) _
& "\" & _
arrFilename(0) & "\"
MakeSureDirectoryPathExists strDestinationPath
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile SelFiles(0), strDestinationPath, True
Set fso = Nothing
'Workbooks.Open strSourcePath
With Workbooks.Open(strDestinationPath & "\" & strFilename)
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 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(Left(Ffn, (InStrRev(Ffn, ".", -1, vbTextCompare) - 1)), " ")
Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)
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 CopyPaste()
Dim strSourcePathame As String, Report As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wbForCopy As Workbook
Set Report = ActiveWorkbook
strSourcePathame = Report.Worksheets(1).Range("A11").Text & ".xlsx"
Set wbForCopy = IsOpen(strSourcePathame)
If Not wbForCopy Is Nothing Then
Set ws1 = wbForCopy.Sheets("Input")
Set ws2 = wbForCopy.Sheets("Avg Daily Vol")
'MsgBox "Good, file opened."
ws1.Range("B8:O11").Copy
ws2.Range("G5").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'MsgBox "Input->Avg Daily Vol values pasted successfully!"
'Second set of copy/paste
Set ws3 = wbForCopy.Sheets("Totals")
'MsgBox "Good, file opened."
ws1.Range("B15:O17").Copy
ws3.Range("I5:V7").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
MsgBox "Values pasted successfully!"
Else
MsgBox "Today's report is currently not opened."
End If
End Sub
Function IsOpen(wbname As String) As Workbook
Dim Wb As Workbook
For Each Wb In Application.Workbooks
If Wb.Name = wbname Then
'MsgBox "Found open workbook"
Set IsOpen = Wb
Exit For
End If
Next Wb
End Function
Private Function GetWorkbook(Wn As String) As Workbook
Dim Wb As Workbook
Dim Sp() As String
Sp = Split(Wn, "\")
Debug.Print Sp(UBound(Sp))
On Error Resume Next
Set GetWorkbook = Workbooks(Sp(UBound(Sp)))
If Err Then
Set GetWorkbook = Workbooks.Open(Wn)
End If
End Function
Private Function MonthNumber(strMonName As String) As Integer
Dim strHold As String
Dim strMonth As String
Dim intMonth As Integer
strMonName = UCase(strMonName)
strMonth = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
strHold = Left(strMonName, 3)
intMonth = InStr(strMonth, strHold)
MonthNumber = intMonth \ 3 + 1
End FunctionASKER
thanks. this work now.
only issue remaining is it seems to have broken one piece of the functionality.
so when you run it and select the file January 1 2013. It shows a text box with the next business day so in this case would show January 2 2013. (Wednesday).
*this part still functions as it should*.
It then takes the values from that input value (January 2 2013), and should use that to rename the file and update A5 to that value.
Right now its running as it should, but even though the input has the new date, it still saves and A5 still shows the date of the file I selected originally.
any ideas what happened?
thanks again in advance.
only issue remaining is it seems to have broken one piece of the functionality.
so when you run it and select the file January 1 2013. It shows a text box with the next business day so in this case would show January 2 2013. (Wednesday).
*this part still functions as it should*.
It then takes the values from that input value (January 2 2013), and should use that to rename the file and update A5 to that value.
Right now its running as it should, but even though the input has the new date, it still saves and A5 still shows the date of the file I selected originally.
any ideas what happened?
thanks again in advance.
Hope this works.
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub CopyWorkbook()
Dim strDestinationPath As String
Dim SelFiles() As String
Dim arrFilename() As String
Dim strFilename As String
Dim strSourcePath As String ' File name
Dim Sp() As String
Dim fso As Object
' modify path as required
strDestinationPath = "H:\Futures\Macros\F&O Report\"
If Right(strDestinationPath, 1) <> "\" Then strDestinationPath = strDestinationPath & "\"
Application.Calculation = xlCalculationAutomatic
If GetSelectedFiles(strDestinationPath, SelFiles) Then
strFilename = Right(SelFiles(0), Len(SelFiles(0)) - InStrRev(SelFiles(0), "\"))
strSourcePath = NewFileName(strFilename)
If Len(strSourcePath) Then
With ThisWorkbook
With .Sheets("F&O Daily")
.Range("A11").Value = strSourcePath
.Range("J11").Value = strDestinationPath
End With
.Save
End With
If Len(strSourcePath) > 0 Then
'Build destination path
arrFilename = Split(strFilename, " ")
strDestinationPath = strDestinationPath & _
IIf(Right(strDestinationPath, 1) = "\", "", "\") & _
Left(arrFilename(2), 4) _
& "\" & _
arrFilename(0) & "\"
'Create destination if it doesn't exist
MakeSureDirectoryPathExists strDestinationPath
'Copy file
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile SelFiles(0), strDestinationPath, True
Set fso = Nothing
'Rename file
Name strDestinationPath & strFilename As arrFilename(0) & " " & arrFilename(1) + 1 & " " & arrFilename(2)
'Workbooks.Open strSourcePath
With Workbooks.Open(strDestinationPath & strFilename)
'Sp = Split(.Name, ".")
'add date
.Sheets("Avg Daily Vol").Range("A5").Value = _
arrFilename(0) & " " & arrFilename(1) + 1 & " " & Left(arrFilename(2), 4)
'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 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(Left(Ffn, (InStrRev(Ffn, ".", -1, vbTextCompare) - 1)), " ")
Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)
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 CopyPaste()
Dim strSourcePathame As String, Report As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wbForCopy As Workbook
Set Report = ActiveWorkbook
strSourcePathame = Report.Worksheets(1).Range("A11").Text & ".xlsx"
Set wbForCopy = IsOpen(strSourcePathame)
If Not wbForCopy Is Nothing Then
Set ws1 = wbForCopy.Sheets("Input")
Set ws2 = wbForCopy.Sheets("Avg Daily Vol")
'MsgBox "Good, file opened."
ws1.Range("B8:O11").Copy
ws2.Range("G5").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'MsgBox "Input->Avg Daily Vol values pasted successfully!"
'Second set of copy/paste
Set ws3 = wbForCopy.Sheets("Totals")
'MsgBox "Good, file opened."
ws1.Range("B15:O17").Copy
ws3.Range("I5:V7").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
MsgBox "Values pasted successfully!"
Else
MsgBox "Today's report is currently not opened."
End If
End Sub
Function IsOpen(wbname As String) As Workbook
Dim Wb As Workbook
For Each Wb In Application.Workbooks
If Wb.Name = wbname Then
'MsgBox "Found open workbook"
Set IsOpen = Wb
Exit For
End If
Next Wb
End Function
Private Function GetWorkbook(Wn As String) As Workbook
Dim Wb As Workbook
Dim Sp() As String
Sp = Split(Wn, "\")
Debug.Print Sp(UBound(Sp))
On Error Resume Next
Set GetWorkbook = Workbooks(Sp(UBound(Sp)))
If Err Then
Set GetWorkbook = Workbooks.Open(Wn)
End If
End Function
Private Function MonthNumber(strMonName As String) As Integer
Dim strHold As String
Dim strMonth As String
Dim intMonth As Integer
strMonName = UCase(strMonName)
strMonth = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
strHold = Left(strMonName, 3)
intMonth = InStr(strMonth, strHold)
MonthNumber = intMonth \ 3 + 1
End FunctionASKER
hi thanks. this is renaming the previous sheet with the new date.
it should be creating a new sheet off of the previous sheet (leaving the previous one in tact).
can you look at the code I originally provided and go off that please?
you search in the dialogue for the book you want to copy.
I.e Today is 2/12/2014.
I select the saved book for 2/10/14, copy and save as 2/11/14.
then it uses the 2/11/14 file and does the necessary work and keeps the new file opened.
it should be creating a new sheet off of the previous sheet (leaving the previous one in tact).
can you look at the code I originally provided and go off that please?
you search in the dialogue for the book you want to copy.
I.e Today is 2/12/2014.
I select the saved book for 2/10/14, copy and save as 2/11/14.
then it uses the 2/11/14 file and does the necessary work and keeps the new file opened.
ASKER
so to be clear , my report is always the business day before the day i actually run the report.
so for today's (2/12) report, I'm creating the report for 2/11. (but using 2/10 the business day before 2/11 as a copy).
so for today's (2/12) report, I'm creating the report for 2/11. (but using 2/10 the business day before 2/11 as a copy).
Sorry, I don't have time for this right now, hopefully I'll get back to it later.
ASKER
ok, im going to be traveling this weekend so i'd really like this fixed before then.
basically if you look at my original code, it worked just fine until i added the new feature.
all i want to do is have what i had before, and just implement the new feature which you helped me with.
thanks!
basically if you look at my original code, it worked just fine until i added the new feature.
all i want to do is have what i had before, and just implement the new feature which you helped me with.
thanks!
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
You are the best! Works perfect!! Thanks!!!!!!!!!!!!!!!!
My gut instinct on this is that the sub folder existence needs to be verified before attempting to save. Please correct me if I am wrong.
G