Looping Through a folder and Saving sheets to a New Folder

[tburger]

I have the below code and I am trying to loop through one directory find all the excel files and break them out into separate sheets each saved in their own folder within a different parent directory. The sheets will all be labeled with the date convention mmddyy. The folder titles will be a date, in the convention yyyymmdd. I added some checks and if the sheet is not 6 characters long it saves it in a separate folder titled Manual. My problem lies when the folder needs to be created. It seems using two Dir functions for 2 separate folders is throwing off the code.

I get the error message Run time Error 5. Invalid procedure call or argument

Any help would be appreciated and this is my first post so if I need to add something please let me know. Thanks.

Sub Separate_Files()
 
Dim wbOpen As Workbook
'Change Path
Const strPath As String = "C:\Users\Owner\Desktop\New Folder\"
Dim strExtension As String
 
 
 
 
ChDir strPath
'Change extension
strExtension = Dir("*.xls")
 
Do While strExtension <> ""
            Set wbOpen = Workbooks.Open((strPath & strExtension), Password:="", WriteResPassword:="", ReadOnly:=True)
            strExtension = Dir


Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Worksheet 'Could be chart, worksheet, Excel 4.0 macro,etc.
Dim strSavePath As String
 
 
Application.ScreenUpdating = True 'Don't show any screen movement
 
strSavePath = "C:\Users\Owner\Desktop\Final\" 'Change this to suit your needs
 
Set wbSource = ActiveWorkbook
 
For Each sht In wbSource.Sheets
 
 
Dim Folder As String
Dim sheetname As String
Dim name As String
Dim name1 As String
 
name = "AllAccounts"
 
sheetname = sht.name
 
Folder = "20" & Right(sheetname, 2) & Left(sheetname, 2) & Mid(sheetname, 3, 2)


            If Dir((strSavePath & Folder), vbDirectory) = "" And Len(sheetname) = 6 Then
            MkDir (strSavePath & Folder)
           
            End If


 
 
Dim strFilename As String
 
If Len(sheetname) <> 6 Then
name1 = sht.name & name
strFilename = strSavePath & "Manual" & "\" & name1
sht.Copy
 
Else
           
 
strFilename = strSavePath & Folder & "\" & name
sht.Copy
 
End If
 
Set wbDest = ActiveWorkbook
 
 
ActiveSheet.name = name
wbDest.SaveAs strFilename
wbDest.Close 'Remove this if you don't want each book closed after saving.
 
Next sht
 
Application.ScreenUpdating = True
wbOpen.Close savechanges = False




      
Loop
       
 
 
End Sub

 

[wigi]

Hello

Indeed, you cannot use 2 nested Dir's. They get in the way of each other.
You could the fylesystemobject.
For code, see for example:
http://www.mrexcel.com/forum/excel-...h-all-xls-files-subdirectories-directory.html

 

[tburger]

Hello

Indeed, you cannot use 2 nested Dir's. They get in the way of each other.
You could the fylesystemobject.
For code, see for example:
http://www.mrexcel.com/forum/excel-...h-all-xls-files-subdirectories-directory.html

That fixes it. Thanks so much for your suggestion.