troubleshooting Question

Excel Macro saving to a specific location help

Avatar of jfrank14
jfrank14 asked on
Microsoft ExcelMicrosoft OfficeVB Script
55 Comments1 Solution390 ViewsLast Modified:
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

Thanks!
ASKER CERTIFIED SOLUTION
Joe Howard

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 1 Answer and 55 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 55 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros