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!

Code:

---

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

---

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.

Code:

---

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

---

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!

Kenneth, great work! Does exactly what I need. Thank you! :bow:

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!

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.

Hi Kenneth,
Thank you for getting back to me quick. Renaming method will work just fine.

Kenneth. I'm sorry, I read your reply wrong. Do nothing if it exists would be the the best option in my case.

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.

Code:

---

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

---

Code:

---

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

---

Dir() is the usual method. e.g.

Code:

---

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

---

Ken, great work again! solved second time!
Thank you much!