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