We help IT Professionals succeed at work.
Get Started

Excel Macro saving to a specific location help

388 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!
Comment
Watch Question
CERTIFIED EXPERT
Commented:
This problem has been solved!
Unlock 1 Answer and 55 Comments.
See Answer
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE