none
If no Directory, then make one RRS feed

  • Question

  • Hi All....

    I would like to know how to have my macro check the Default Directory, and if there is a SubDirectory there named "Backups" then save this file to it.  If there is no SubDirectory named "Backups" then create one and then save this file to it.

    Any help would be much appreciated,

    Vaya con Dios,

    Chuck, CABGx3


    Chuck, CABGx3

    Friday, January 11, 2013 2:58 AM

Answers

  • Adapt the following -

    Sub test()
    Dim sMainFldr As String
    Dim sSubName As String
    Dim sSubFldr As String
            sMainFldr = Application.DefaultFilePath
         sSubName = "Backups"
            If GetMakeSubFldr(sMainFldr, sSubName, sSubFldr) Then
                    ActiveWorkbook.SaveCopyAs sSubFldr & "\" & ActiveWorkbook.Name &
    ".bak"
         Else
                 MsgBox "failed to make " & vbCr & sSubFldr
         End If
    End Sub
    
    Function GetMakeSubFldr(sMainFldr As String, sSubName As String, sSubFldr As
    String)
            If Not FolderExists(sMainFldr) Then
                 'MsgBox "sMainFldr does not exist"
         Else
                 GetMakeSubFldr = True
                 sSubFldr = sMainFldr
                    If Right$(sSubFldr, 1) <> "\" Then
                         sSubFldr = sSubFldr & "\"
                 End If
                 sSubFldr = sSubFldr & sSubName
                 sSubFldr = sSubFldr & sLast
                 If Not FolderExists(sSubFldr) Then
                         On Error Resume Next
                         MkDir sSubFldr
                         GetMakeSubFldr = Not Err.Number
                 End If
         End If
    
    End Function
    
    Function FolderExists(sFldr As String) As Boolean
    Dim nAttr As Long
         On Error Resume Next
        nAttr = GetAttr(sFldr)
        FolderExists = (Err.Number = 0) And ((nAttr And vbDirectory) =
    vbDirectory)
    
    End Function

    Peter Thornton

    • Marked as answer by CABGx3 Friday, January 11, 2013 3:56 PM
    Friday, January 11, 2013 11:34 AM
    Moderator

All replies

  • Adapt the following -

    Sub test()
    Dim sMainFldr As String
    Dim sSubName As String
    Dim sSubFldr As String
            sMainFldr = Application.DefaultFilePath
         sSubName = "Backups"
            If GetMakeSubFldr(sMainFldr, sSubName, sSubFldr) Then
                    ActiveWorkbook.SaveCopyAs sSubFldr & "\" & ActiveWorkbook.Name &
    ".bak"
         Else
                 MsgBox "failed to make " & vbCr & sSubFldr
         End If
    End Sub
    
    Function GetMakeSubFldr(sMainFldr As String, sSubName As String, sSubFldr As
    String)
            If Not FolderExists(sMainFldr) Then
                 'MsgBox "sMainFldr does not exist"
         Else
                 GetMakeSubFldr = True
                 sSubFldr = sMainFldr
                    If Right$(sSubFldr, 1) <> "\" Then
                         sSubFldr = sSubFldr & "\"
                 End If
                 sSubFldr = sSubFldr & sSubName
                 sSubFldr = sSubFldr & sLast
                 If Not FolderExists(sSubFldr) Then
                         On Error Resume Next
                         MkDir sSubFldr
                         GetMakeSubFldr = Not Err.Number
                 End If
         End If
    
    End Function
    
    Function FolderExists(sFldr As String) As Boolean
    Dim nAttr As Long
         On Error Resume Next
        nAttr = GetAttr(sFldr)
        FolderExists = (Err.Number = 0) And ((nAttr And vbDirectory) =
    vbDirectory)
    
    End Function

    Peter Thornton

    • Marked as answer by CABGx3 Friday, January 11, 2013 3:56 PM
    Friday, January 11, 2013 11:34 AM
    Moderator
  • Looks great Peter, I'll give it a shot.

    Many thanks,

    Chuck, CABGx3


    Chuck, CABGx3

    Friday, January 11, 2013 3:57 PM