Solved

Excel Macro saving to a specific location help

Posted on 2013-12-20
56
291 Views
Last Modified: 2014-02-14
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:

Option Explicit
Sub CopyWorkbook()

    ' modify path as required
    Const PathName As String = "Z:\Report"
    
    Dim SelFiles() As String
    Dim Fn As String                        ' File name
    Dim Sp() As String
   
    
    If GetSelectedFiles(PathName, SelFiles) Then
        Fn = NewFileName(SelFiles(0))
        If Len(Fn) Then
            Fn = WithSeparator(PathName) & Fn & ".xlsx"
            FileCopy SelFiles(0), Fn
            Workbooks.Open Fn
            With Workbooks.Open(Fn)
                Application.Calculation = xlCalculationAutomatic
                Sp = Split(.Name, ".")
                'add date
                .Sheets("Avg Daily Vol").Range("A5").Value = _
                        Left(.Name, Len(.Name) - (Len(Sp(UBound(Sp))) + 1))
                        
                'increment MTD, QTD, YTD
                .Sheets("Input").Range("B20").Value = _
                        .Sheets("Input").Range("B20").Value + 1
                        
                        .Sheets("Input").Range("B21").Value = _
                        .Sheets("Input").Range("B21").Value + 1
                        
                        .Sheets("Input").Range("B22").Value = _
                        .Sheets("Input").Range("B22").Value + 1
            End With
            'CloseThisWorkbook
        Else
            MsgBox "No valid file name was supplied.", _
                   vbCritical, "Can't rename"
        End If
    End If
End Sub

Private Function GetSelectedFiles(Pn As String, _
                                  SelFiles() As String) _
                                  As Boolean
    ' 0086 V 1.0
    
    Dim FoD As FileDialog                           ' File Open Dialog
    Dim SelItem As Variant                          ' Selected Item
    Dim i As Long                                   ' Index for SelFiles
    Dim DefaultDate As Date
    
    DefaultDate = Application.WorksheetFunction.WorkDay(Date, -2)
    Set FoD = Application.FileDialog(msoFileDialogFilePicker)
    With FoD
        .Title = "Choose the workbook to copy"
        .ButtonName = "Create Copy"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls*", 1
        .InitialFileName = WithSeparator(Pn) & _
                           Format(DefaultDate, "MMMM d yyyy") _
                           & ".xlsx"
        .AllowMultiSelect = False
        If .Show Then
            For Each SelItem In .SelectedItems
               ReDim Preserve SelFiles(i)
               SelFiles(i) = SelItem
               i = i + 1
            Next SelItem
            GetSelectedFiles = True
        End If
    End With
    Set FoD = Nothing
End Function

Private Function NewFileName(Ffn As String) As String

    Dim Sp() As String
    Dim Fn As String                ' File name (old)
    Dim Fnn As String               ' File name New
    Dim Fd As Date                  ' File date
    
    Sp = Split(Ffn, "\")
    Fn = Split(Sp(UBound(Sp)), ".")(0)
    If IsDate(Fn) Then
        Fd = Application.WorksheetFunction.WorkDay(CDate(Fn), 1)
        Fnn = Format(Fd, "mmmm d yyyy")
        Fn = Fn
    End If
    NewFileName = InputBox("Copying the workbook" & vbCr & _
                           "of " & Fn & Format(CDate(Fn), "  (dddd)") & vbCr & _
                           "Please confirm or enter " & _
                           "the copy's file name." & vbCr & vbCr & _
                           IIf(IsDate(Fn), "(" & Format(Fd, "dddd") & _
                           ")", ""), "New file name", Fnn)
End Function

Private Function WithSeparator(ByVal PathName As String, _
                               Optional ByVal RemoveExisting As Boolean) _
                               As String
                       
    Do While Right(PathName, 1) = Application.PathSeparator
        PathName = Left(PathName, Len(PathName) - 1)
    Loop
    WithSeparator = PathName & IIf(RemoveExisting, "", _
                                   Application.PathSeparator)
End Function

'Sub CloseWorkbook()
'    SetAppScreen False
'    ThisWorkbook.Close SaveChanges:=xlDoNotSaveChanges
'End Sub

Open in new window


Thanks!
0
Comment
Question by:jfrank14
  • 27
  • 19
  • 8
  • +1
56 Comments
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39732369
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
0
 

Author Comment

by:jfrank14
ID: 39732746
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.
0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39732791
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

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

Author Comment

by:jfrank14
ID: 39732795
Input just says:

December 20 2013
0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39732819
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.
0
 

Author Comment

by:jfrank14
ID: 39732867
Hi,
can you please help me in getting this to what i need? Can you please explain what to change/add?

thanks.
0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39732915
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

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

Author Comment

by:jfrank14
ID: 39732968
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.
0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39733020
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
0
 

Author Comment

by:jfrank14
ID: 39733041
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

Open in new window

0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39733113
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.
0
 

Author Comment

by:jfrank14
ID: 39737006
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.
0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39738344
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.
0
 

Author Comment

by:jfrank14
ID: 39780101
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

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39786839
hi - any luck?
0
 
LVL 10

Expert Comment

by:GeoffSutton
ID: 39787266
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
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39838326
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

Open in new window

0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39838448
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

Open in new window

0
 
LVL 23

Expert Comment

by:JSRWilson
ID: 39838459
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
0
 

Author Comment

by:jfrank14
ID: 39840157
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?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39840180
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

Open in new window

and on line 50 change this:
checkFolder (pathName)

Open in new window

to this:
MyMkDir strDestination

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39840305
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?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39840472
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

Open in new window


then change
MyMkDir pathName

Open in new window

to
MakeSureDirectoryPathExists pathName

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39840517
hey - so i did that, no errors and completes.

however, it doesn't create the folders!

per ID: 39840157
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39840530
Works for me! Do you have write permissions to the destination?

Is this your pathName: "H:\Futures\Macros\F&OReport\"
0
 

Author Comment

by:jfrank14
ID: 39840540
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
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39840580
It needs the closing slash i.e. H:\Futures\Macros\F&O Report\
0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 

Author Comment

by:jfrank14
ID: 39843261
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

Open in new window

0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39844372
Add a message box after line 43, does it show?
0
 

Author Comment

by:jfrank14
ID: 39847328
hi , yes it does show.
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39847356
I don't know. It works fine by me.
0
 

Author Comment

by:jfrank14
ID: 39847486
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).
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39847616
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

Open in new window

0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39847620
Here's the explanation:

Ok, let's break it down.

1.
Filename = Split(Fn, " ")

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)

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 & _

Open in new window

pathName in your example would be: H:\Futures\Macros\F&O Report\
IIf(Right(pathName, 1) = "\", "", "\") & _

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

Open in new window

   Now we add the month name to the path.
   
& "\" & _

Open in new window

   Self explainitory.
   
Left(Filename(2), 4)

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
0
 

Author Comment

by:jfrank14
ID: 39847683
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?
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39847706
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)

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

Author Comment

by:jfrank14
ID: 39847750
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

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39847761
see attached sample
F-O-Report-sample.xlsm
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39847831
Your example doesn't help with out the data file.
0
 

Author Comment

by:jfrank14
ID: 39847900
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39849504
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

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39850286
subscript out of range on line 115:
    Fn = MonthNumber(Sp(0)) & "-" & Sp(1) & "-" & Sp(2)
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39850791
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).
0
 

Author Comment

by:jfrank14
ID: 39850836
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.
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39850881
Change line 114-115 to:
    Sp = Split(Left(Ffn, (InStrRev(Ffn, ".", -1, vbTextCompare) - 1)), "-")
    Fn = MonthNumber(Sp(0)) & " " & Sp(1) & " " & Sp(2)

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39851039
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
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39851117
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

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39851187
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.
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39851527
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

Open in new window

0
 

Author Comment

by:jfrank14
ID: 39853593
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.
0
 

Author Comment

by:jfrank14
ID: 39853598
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).
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 39855632
Sorry, I don't have time for this right now, hopefully I'll get back to it later.
0
 

Author Comment

by:jfrank14
ID: 39857433
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!
0
 
LVL 26

Accepted Solution

by:
MacroShadow earned 500 total points
ID: 39858237
This is my last try, I spent more time than I can afford on 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\"

    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 & arrFilename(0) & " " & arrFilename(1) + 1 & " " & arrFilename(2), True
                Set fso = Nothing
                
                'Workbooks.Open strSourcePath
                With Workbooks.Open(strDestinationPath & arrFilename(0) & " " & arrFilename(1) + 1 & " " & arrFilename(2))

                    '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

Open in new window

0
 

Author Closing Comment

by:jfrank14
ID: 39858977
You are the best! Works perfect!! Thanks!!!!!!!!!!!!!!!!
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now