Excel Macro saving to a specific location help

It has been a long time since I've touched vba in excel, but a couple of things I noticed.  I don't see any msgbox for debugging to highlight what values are at different points.  Are the subfolders already created under z:\reports?  If not, you need to check if those folders exist and create them if they do not.  What value is displayed in your input box?  Is it the correct address you want the files to be saved in?  If so, then your problem isn't code but folder structure.  If not, then you can look at code.  

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

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.

Exactly.  Right now, does the input box display "z:\reports\2013\december\December 20 2013.xlsx" or just "December 20 2013.xlsx"?

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 i

Select all Open in new window

I forget if vba is 0 based or 1 based.  If 0, then this will work, if 1, then set i=2, not i=1.

Input just says:

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.

Hi,
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:

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 sub

Select all Open in new window

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.

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.

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

hightlighting Sub checkfolder(pathName As String)
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

Select all Open in new window

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.

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.

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\) then append the filename, and the job should be done.

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?

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 Sub

Select all Open in new window

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

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

Select all Open in new window

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

Select all Open in new window

You can check if a folder exists in a couple of lines

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
MsgBox fso.FolderExists("C:\Test\") ' returns True or False

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?

Delete the check folder routine it is full of errors!
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 Sub

Select all Open in new window

and on line 50 change this:

checkFolder (pathName)

Select all Open in new window

to this:

MyMkDir strDestination

Select all Open in new window

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&OReport\H:\
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):

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Select all Open in new window

then change

MyMkDir pathName

Select all Open in new window

to

MakeSureDirectoryPathExists pathName

Select all Open in new window

hey - so i did that, no errors and completes.

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&OReport\"

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

It needs the closing slash i.e. H:\Futures\Macros\F&O Report\

tried that too. no errors, did all the work but did not create the folder directories.

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

Select all Open in new window

Add a message box after line 43, does it show?

hi , yes it does show.

I don't know. It works fine by me.

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).

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

Select all Open in new window

Here's the explanation:

Ok, let's break it down.

1.

Filename = Split(Fn, " ")

Select all Open in new window

Filename is a string array. In this line we populate the array with the words in the file name (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)

Select all Open in new window

This is realy one line, but I broke it up for clarities sake.
In this line we set the path as follows:

pathName = pathName & _

Select all Open in new window

pathName in your example would be: H:\Futures\Macros\F&O Report\

IIf(Right(pathName, 1) = "\", "", "\") & _

Select all Open in new window

If right-most charachter in the path is a slash, do nothing otherwise add one. So in your example nothing is added.
   

Filename(0) _

Select all Open in new window

   Now we add the month name to the path.
   

& "\" & _

Select all Open in new window

   Self explainitory.
   

Left(Filename(2), 4)

Select all Open in new window

In this line we extract the 4 left-most characters from the last element of the array which in your example is 2013.xlsx.

Viola, the full path should be:
H:\Futures\Macros\F&O Report\December\2013

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

This will do it:

pathName = pathName & _
                 IIf(Right(pathName, 1) = "\", "", "\") & _
                 Left(Filename(2), 4) _
                 & "\" & _
                 Filename(0)

Select all Open in new window

imagehlp.dll is a system dll, if you have Windows you have it!

If you want help debugging please upload a sample file.

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:

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 Sub

Select all Open in new window

see attached sample
F-O-Report-sample.xlsm

Your example doesn't help with out the data file.

January-2-2013.xlsx

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 Function

Select all Open in new window

subscript out of range on line 115:
    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).

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.

Change line 114-115 to:

    Sp = Split(Left(Ffn, (InStrRev(Ffn, ".", -1, vbTextCompare) - 1)), "-")
    Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)

Select all Open in new window

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

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 Function

Select all Open in new window

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.

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 Function

Select all Open in new window

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.

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).

Sorry, I don't have time for this right now, hopefully I'll get back to it later.

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!

You are the best! Works perfect!! Thanks!!!!!!!!!!!!!!!!