VBA creating new folders and files

[IvanTs8]

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

[Kenneth Hobs]

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

[IvanTs8]

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!

[IvanTs8]

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

[IvanTs8]

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!

[Kenneth Hobs]

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.

[IvanTs8]

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

[IvanTs8]

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

[Kenneth Hobs]

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

[Kenneth Hobs]

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

[IvanTs8]

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