script issue
Sems to be a problem with this. I have FirstName(Cell A1) and LastName (Cell B1) and then list the names underneath but am getting a double dash for the first folder and it is only listing the next name then ignoring the rest?
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strMyDocs = objShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\My Documents"
strShortcutPath = "C:\1234.vbs"
'Create TFP folder
If objFSO.FolderExists(strMyDocs & "\TFP") = False Then objFSO.CreateFolder strMyDocs & "\TFP"
'Create Names.xls
If objFSO.FileExists(strMyDocs & "\TFP\names.xls") = False Then
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
intSheetsInNewWB = objExcel.SheetsInNewWorkbook
objExcel.SheetsInNewWorkbook = 1
Set objWB = objExcel.Workbooks.Add
objExcel.SheetsInNewWorkbook = intSheetsInNewWB
Set objSheet = objWB.Sheets(1)
objSheet.Rows("1:1").Font.Bold = True
objSheet.Cells(1, "A") = "FirstName"
objSheet.Cells(1, "B") = "LastName"
objWB.SaveAs strMyDocs & "\TFP\names.xls"
End If
'Create Instructions.txt
If objFSO.FileExists(strMyDocs & "\TFP\Instructions.txt") = False Then
Set objFile = objFSO.CreateTextFile(strMyDocs & "\TFP\Instructions.txt", True)
objFile.Write "Please add your names to the Excel file called ""names"" and then click save and close the file. Then click on the Create Folders Icon."
objFile.Close
Set objFile = Nothing
objShell.Run "notepad """ & strMyDocs & "\TFP\Instructions.txt" & """", 1, False
End If
'Create Create Folders.lnk
If objFSO.FileExists(strMyDocs & "\TFP\Create Folders.lnk") = False Then
' There may be a truncation issue with the shorcut path: See http://support.microsoft.com/kb/263324
Set objShortcut = objShell.CreateShortcut(strMyDocs & "\TFP\Create Folders.lnk")
objShortcut.TargetPath = strShortcutPath
objShortcut.Save
Set objShortcut = Nothing
End If
objShell.Run "explorer.exe /n, """ & strMyDocs & "\TFP""", 1, False
MsgBox "Done"
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thanks guys.
Hi, your code works fine for me, although I did start my names in the XLS on row 5, because of this line:
For Each cell In ws.Range("A5:A" & lastrow)
If you want it to pick names starting from row 2, change that line to this:
For Each cell In ws.Range("A2:A" & lastrow)
Also, I have added a condition to not make any folders if the name on a row is blank.
Regards,
Rob.
For Each cell In ws.Range("A5:A" & lastrow)
If you want it to pick names starting from row 2, change that line to this:
For Each cell In ws.Range("A2:A" & lastrow)
Also, I have added a condition to not make any folders if the name on a row is blank.
Regards,
Rob.
Dim myName 'As String
Dim main_fldr 'As String
Dim subfldr1 'As String
Dim subfldr2 'As String
Dim lastrow 'As Integer
Dim cell 'As Object
Const xlUp = -4162 '(&HFFFFEFBE)
Set objWshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strUserProfile = objWshShell.Environment("PROCESS")("UserProfile")
strNewDirectory = strUserProfile + "\My Documents\Students"
If objfso.FolderExists(strnewdirectory) = False Then
Set objFolder = objFSO.CreateFolder(strNewDirectory)
End If
subfldr1 = inputbox("Do you want to add a subfolder to the childs folder? ", "Folder name", "add subfolder name here") 'folder1
subfldr2 = inputbox("What is the second foldername? If you add nothing a folder will not be created", "Folder name", "") 'folder2
mynames = strUserProfile & "\My Documents\names.xls" 'location of the excel spreadsheet
worksheetname = "Sheet1" 'name of the worksheet within excel
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(mynames)
objExcel.Visible = False
set ws = objExcel.activeworkbook.Worksheets(worksheetname)
objExcel.Displayalerts = false
'find the lastrow on the sheet
lastrow = ws.Range("A65536").End(xlUp).Row
'make the folders
For Each cell In ws.Range("A5:A" & lastrow)
If Trim(cell.Value) <> "" Then
myName = cell.Value & "_" & cell.Offset(0, 1).Value
'Call MkDir(strNewDirectory & "\") remove this.. its created already
Call MkDir(strNewDirectory & "\" & myName & "\")
Call MkDir(strNewDirectory & "\" & myName & "\" & subfldr1 & "\")
Call MkDir(strNewDirectory & "\" & myName & "\" & subfldr2 & "\")
End If
Next
objExcel.Displayalerts = true
objexcel.Quit
wscript.quit
Function MkDir(strPath)
Dim strParentPath, objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
strParentPath = objFSO.GetParentFolderName(strPath)
If Not objFSO.FolderExists(strParentPath) Then MkDir strParentPath
If Not objFSO.FolderExists(strPath) Then objFSO.CreateFolder strPath
On Error Goto 0
MakeDir = objFSO.FolderExists(strPath)
End Function
ASKER
Open in new window