Consulting

Results 1 to 11 of 11

Thread: VBA creating new folders and files

  1. #1
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location

    VBA creating new folders and files

    Hello all,
    I'm very new here. I have some VBA knowledge but not much. Usually I search and edit codes to fit my needs, but this time I'm stuck and could use some advice.
    Here is what I'm looking to accomplish with my code.
    I currently have a code that creates folders and sub folders using cell value as main folder name. I would like within this same code, to be able to Save As one of the sheets as a new file in one of the newly created sub folders.
    Below is the code I'm using. Works fine and does everything it needs to do.
    I have a tab/sheet named "Test Plan" to be saved under sub folder "Test Info" with the vehicle number from "B1" as name. If its possible to have TP before or after the vehicle number in the name, would be even better. example TP BY1111242.xls or BY1111242 TP.xls

    For some reason, I'm denied to post an excel screen shot.

    Thank you very much!

    Sub MakeFolder()
    Dim strVehNum As String, strPathDefault As String, strFolderTestInfo As String, strFolderPics As String, strFolderServiceComments As String, strFolderPrintouts As String
    Dim FSO As New FileSystemObject
    strVehNum = Range("B1") ' assumes vehicle number in B1
    strPath = "G:\03 PROJECTS\AUTOS"
    strFolderTestInfo = "Test info"
    strFolderPics = "Pics"
    strFolderServiceComments = "Service comments"
    strFolderPrintouts = "Printouts"
    If Not FSO.FolderExists(strPath & strVehNum) Then
        FSO.CreateFolder strPath & strVehNum
        FSO.CreateFolder strPath & strVehNum & "" & strFolderTestInfo
        FSO.CreateFolder strPath & strVehNum & "" & strFolderPics
        FSO.CreateFolder strPath & strVehNum & "" & strFolderServiceComments
        FSO.CreateFolder strPath & strVehNum & "" & strFolderPrintouts
    Else
    End If
        UserName
    End Sub
    Last edited by Aussiebear; 12-15-2018 at 04:01 PM. Reason: Added tags to code

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Welcome to the forum! When posting code, please paste between code tags. Click the # on toolbar to insert the tags.

    Images are less helpful than code and files. Links can not be posted until after 5 posts I believe.

    I am not sure how that works since it looks like you do not have a trailing backslash character. The quotes have it missing too I suspect.

    Sub MakeFolder()  
      Dim strVehNum As String, strPathDefault As String, strFolderTestInfo As String
      Dim strFolderPics As String, strFolderServiceComments As String
      Dim strFolderPrintouts As String, strPath As String, FSO As New FileSystemObject
      Dim fn As String
      
      strVehNum = Range("B1") ' assumes vehicle number in B1
       strPath = "G:\03 PROJECTS\AUTOS\"
      strFolderTestInfo = "Test info"
      strFolderPics = "Pics"
      strFolderServiceComments = "Service comments"
      strFolderPrintouts = "Printouts"
      
      If Not FSO.FolderExists(strPath & strVehNum) Then
        FSO.CreateFolder strPath & strVehNum
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderTestInfo
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderPics
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderServiceComments
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderPrintouts
      End If
      'UserName
      
      fn = strPath & strVehNum & "\" & strFolderTestInfo & "\TP " & strVehNum & ".xls"
      With Workbooks.Add(xlWBATWorksheet)
        ThisWorkbook.Worksheets("Test Plan").Copy after:=.Sheets(1)
        Application.DisplayAlerts = False
        .Sheets(1).Delete
        Application.DisplayAlerts = True
        On Error Resume Next
        Kill fn
        .SaveAs fn, xlExcel8
        .Close False
      End With
    End Sub

  3. #3
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location
    Kenneth, thank you for the replay. I have been away from my little project, and focused on something else. I will try and give feedback. Thanks again!

  4. #4
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location
    Kenneth, great work! Does exactly what I need. Thank you!

  5. #5
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location
    Hello Kenneth,
    I got one more question if you could help. I just realized that if create a folder and file with the same name as one of the previous ones, it saves over that file and replaces all data inside with new one. I would like if possible for the code to search in the folder, and if file exists, not to overwrite. Basically do nothing. And if possible save as password protected .xls so no changes can be made to the sheet.

    Greatly appreciated!

  6. #6
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    It could be made into a read-only file. If we just password protected the sheet and not the workbook, the sheet could be deleted. So, I guess you want the sheet and workbook password protected?

    As for not overwriting, we could do nothing if it existed if you like. Another option might be to rename the file using a Windows method. e.g. ken.xls, ken (2).xls and so on.

  7. #7
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location
    Hi Kenneth,
    Thank you for getting back to me quick. Renaming method will work just fine.

  8. #8
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location
    Kenneth. I'm sorry, I read your reply wrong. Do nothing if it exists would be the the best option in my case.

  9. #9
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Change the two passwords of "ken" to suit. Add the Module from the link to the kb article that I wrote. Or just add a new Module and put all of the 2nd code block into it.

    The filenames will be like "ken (1).xls", "ken (2).xls", etc. Read my kb article and view my example file for other tips about unique filenames using API methods.
    Sub MakeFolder()
      Dim strVehNum As String, strPathDefault As String, strFolderTestInfo As String
      Dim strFolderPics As String, strFolderServiceComments As String
      Dim strFolderPrintouts As String, strPath As String, FSO As New FileSystemObject
      Dim fn As String
      
      strVehNum = Range("B1") ' assumes vehicle number in B1
      strPath = "G:\03 PROJECTS\AUTOS"
      strPath = "c:\test"
      strFolderTestInfo = "Test info"
      strFolderPics = "Pics"
      strFolderServiceComments = "Service comments"
      strFolderPrintouts = "Printouts"
      
      If Not FSO.FolderExists(strPath & strVehNum) Then
        FSO.CreateFolder strPath & strVehNum
        FSO.CreateFolder strPath & strVehNum & "" & strFolderTestInfo
        FSO.CreateFolder strPath & strVehNum & "" & strFolderPics
        FSO.CreateFolder strPath & strVehNum & "" & strFolderServiceComments
        FSO.CreateFolder strPath & strVehNum & "" & strFolderPrintouts
      End If
      'UserName
      
      fn = strPath & strVehNum & "" & strFolderTestInfo & "\TP " & strVehNum & ".xls"
      'http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041
      fn = MakeUnique(fn)
      With Workbooks.Add(xlWBATWorksheet)
        ThisWorkbook.Worksheets("Test Plan").Copy after:=.Sheets(1)
        .Worksheets(Worksheets.Count).Protect "ken"
        Application.DisplayAlerts = False
        .Sheets(1).Delete
        Application.DisplayAlerts = True
        On Error Resume Next
        Kill fn
        .SaveAs fn, xlExcel8, "ken"
        .Close False
      End With
    End Sub
    Option Explicit
    'This kb article:
    'http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041
    
    
    'Another sequential filename
    'tstav,http://vbaexpress.com/kb/getarticle.php?kb_id=1008
    
    
    Const Max_Path As String = 260
    'http://msdn.microsoft.com/en-us/library/bb776479.aspx
    Public Declare Function PathYetAnotherMakeUniqueName _
      Lib "shell32.dll" _
      ( _
      ByVal pszUniqueName As String, _
      ByVal pszPath As String, _
      ByVal pszShort As String, _
      ByVal pszFileSpec As String _
      ) As Boolean
    
    
    'http://msdn.microsoft.com/en-us/library/bb776479.aspx
    Public Declare Function PathMakeUniqueName _
      Lib "shell32.dll" _
      ( _
      ByVal pszUniqueName As String, _
      ByVal cchMax As Long, _
      ByVal pszTemplate As String, _
      ByVal pszLongPlate As String, _
      ByVal pszDir As String _
      ) As Boolean
      
    Function fMakeAnotherUnique(vShortTemplate, vLongTemplate, vFolder) As String
      'vFolder can end in trailing backslash or not
      Dim rc As Boolean, vUniqueName As String, s As String
      vUniqueName = Space$(Max_Path)
      rc = PathYetAnotherMakeUniqueName(vUniqueName, StrConv(vFolder, vbUnicode), _
        StrConv(vShortTemplate, vbUnicode), StrConv(vLongTemplate, vbUnicode))
      If rc Then
        vUniqueName = StrConv(vUniqueName, vbFromUnicode)
        fMakeAnotherUnique = vUniqueName
      End If
    End Function
    
    
    Function MakeAnotherUnique(filespec As String) As String
      MakeAnotherUnique = fMakeAnotherUnique("", GetFileName(filespec), GetFolderName(filespec))
    End Function
    
    
    Function fMakeUnique(vShortTemplate, vLongTemplate, vFolder) As String
      'vFolder can end in trailing backslash or not
      Dim rc As Boolean, vUniqueName As String, s As String
      vUniqueName = Space$(Max_Path)
      rc = PathMakeUniqueName(vUniqueName, Max_Path, StrConv(vShortTemplate, vbUnicode), _
        StrConv(vLongTemplate, vbUnicode), StrConv(vFolder, vbUnicode))
      If rc Then
        vUniqueName = StrConv(vUniqueName, vbFromUnicode)
        fMakeUnique = vUniqueName
      End If
    End Function
    
    
    Function MakeUnique(filespec As String) As String
      MakeUnique = fMakeUnique("", GetFileName(filespec), GetFolderName(filespec))
    End Function
    
    
    Function GetFileName(filespec As String) As String
      Dim p1 As Integer, p2 As Integer
      p1 = InStrRev(filespec, "\")
      p2 = Len(filespec) - p1
      GetFileName = Mid$(filespec, p1 + 1, p2)
    End Function
    
    
    Function GetFolderName(filespec As String) As String
      Dim p1 As Integer
      p1 = InStrRev(filespec, "\")
      GetFolderName = Left$(filespec, p1)
    End Function

  10. #10
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Dir() is the usual method. e.g.
    Sub MakeFolder()  
      Dim strVehNum As String, strPathDefault As String, strFolderTestInfo As String
      Dim strFolderPics As String, strFolderServiceComments As String
      Dim strFolderPrintouts As String, strPath As String, FSO As New FileSystemObject
      Dim fn As String
      
      strVehNum = Range("B1") ' assumes vehicle number in B1
      strPath = "G:\03 PROJECTS\AUTOS\"
      strPath = "c:\test\"
      strFolderTestInfo = "Test info"
      strFolderPics = "Pics"
      strFolderServiceComments = "Service comments"
      strFolderPrintouts = "Printouts"
      
      If Not FSO.FolderExists(strPath & strVehNum) Then
        FSO.CreateFolder strPath & strVehNum
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderTestInfo
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderPics
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderServiceComments
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderPrintouts
      End If
      'UserName
      
      fn = strPath & strVehNum & "\" & strFolderTestInfo & "\TP " & strVehNum & ".xls"
      'http://www.vbaexpress.com/kb/getarticle.php?kb_id=1041
      fn = MakeUnique(fn)
      With Workbooks.Add(xlWBATWorksheet)
        ThisWorkbook.Worksheets("Test Plan").Copy after:=.Sheets(1)
        .Worksheets(Worksheets.Count).Protect "ken"
        Application.DisplayAlerts = False
        .Sheets(1).Delete
        Application.DisplayAlerts = True
        On Error Resume Next
        Kill fn
        .SaveAs fn, xlExcel8, "ken"
        .Close False
      End With
    End Sub
    
    
    
    
    Sub MakeFolder()
      Dim strVehNum As String, strPathDefault As String, strFolderTestInfo As String
      Dim strFolderPics As String, strFolderServiceComments As String
      Dim strFolderPrintouts As String, strPath As String, FSO As New FileSystemObject
      Dim fn As String
      
      strVehNum = Range("B1") ' assumes vehicle number in B1
      strPath = "G:\03 PROJECTS\AUTOS\"
      strFolderTestInfo = "Test info"
      strFolderPics = "Pics"
      strFolderServiceComments = "Service comments"
      strFolderPrintouts = "Printouts"
      
      If Not FSO.FolderExists(strPath & strVehNum) Then
        FSO.CreateFolder strPath & strVehNum
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderTestInfo
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderPics
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderServiceComments
        FSO.CreateFolder strPath & strVehNum & "\" & strFolderPrintouts
      End If
      
      fn = strPath & strVehNum & "\" & strFolderTestInfo & "\TP " & strVehNum & ".xls"
      If Dir(fn) <> "" Then Exit Sub
    
    
      With Workbooks.Add(xlWBATWorksheet)
        ThisWorkbook.Worksheets("Test Plan").Copy after:=.Sheets(1)
        .Worksheets(Worksheets.Count).Protect "ken"
        Application.DisplayAlerts = False
        .Sheets(1).Delete
        Application.DisplayAlerts = True
        On Error Resume Next
        Kill fn
        .SaveAs fn, xlExcel8, "ken"
        .Close False
      End With
    End Sub

  11. #11
    VBAX Regular
    Joined
    Dec 2018
    Posts
    11
    Location
    Ken, great work again! solved second time!
    Thank you much!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •