Create new directory for today's date

[brianlois]

Hello,

I am trying to create a directory with today's date MMDDYYYY (if its not already created) and then move all files to that new directory.

For example:

enddir = "C:\Temp\MMDDYYYY"

Any help would be appreciated,
Thanks.

Sub FindClientExcelFiles()
Dim FS As Office.FileSearch
Dim vaFileName As Variant
Dim startdir
Dim enddir
Dim Foo As Object
Dim iCount As Long
Dim newname As Variant
startdir = "C:\Temp\1"
enddir = "C:\Temp\2\"
Set FS = Application.FileSearch
With FS
'Clear old search criteria
.NewSearch
'Directory to search
.LookIn = startdir
'Include sub folders in search
.SearchSubFolders = True
'Look for Excel files
.FileType = msoFileTypeExcelWorkbooks
'Doesn't matter when last modified
.LastModified = msoLastModifiedAnyTime
iCount = .Execute
For Each vaFileName In .FoundFiles
Set Foo = Workbooks.Open(vaFileName)
Foo.Save
Foo.Close
newname = Mid(vaFileName, InStrRev(vaFileName, "\") + 1)
Name vaFileName As enddir & newname
Next vaFileName
End With
End Sub

[Regouin]

Hello,

use vba tags for your vba code [ vba ] [ /vba ]

include this somewhere in your formula

Dim fsoObj As Object
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If .FolderExists("C:\temp\" & Date & "\") Then
Else
.CreateFolder ("C:\temp\" & Date & "\") 
        End If
Application.ScreenUpdating = False

that creates a folder with today's date. now copy everything there you need to copy.

[brianlois]

Thank you. I am getting this error after entering your code into my macro:

.CreateFolder ("C:\Temp" & Date & "") << Path Not Found

What did I do wrong?

Sub FindClientExcelFiles()
Dim FS As Office.FileSearch
Dim vaFileName As Variant
Dim startdir
Dim enddir
Dim Foo As Object
Dim iCount As Long
Dim newname As Variant
Dim fsoObj As Object
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If .FolderExists("C:\Temp\" & Date & "\") Then
Else
.CreateFolder ("C:\Temp\" & Date & "\")
End If
Application.ScreenUpdating = False
End With
startdir = "C:\Temp\1"
enddir = ("C:\Temp\" & Date & "\")
Set FS = Application.FileSearch
With FS
'Clear old search criteria
.NewSearch
'Directory to search
.LookIn = startdir
'Include sub folders in search
.SearchSubFolders = True
'Look for Excel files
.FileType = msoFileTypeExcelWorkbooks
'Doesn't matter when last modified
.LastModified = msoLastModifiedAnyTime
iCount = .Execute
'List the files in the FoundFiles collection
For Each vaFileName In .FoundFiles
Set Foo = Workbooks.Open(vaFileName)
Foo.Save
Foo.Close
newname = Mid(vaFileName, InStrRev(vaFileName, "\") + 1)
Name vaFileName As enddir & newname
Next vaFileName
End With
End Sub

[Regouin]

mmm cant get it to work right now, I'll see if I can work around it later

[mvidas]

It could be because Date is returning the full date (with / which cant be in a folder name). Try creating a string variable at the top, and using that variable instead throughout the code:

Dim fsoObj As Object, TheDate As String
 TheDate = Format(Date, "MMDDYYYY")
 enddir = ("C:\Temp\" & TheDate & "\")
 Set fsoObj = CreateObject("Scripting.FileSystemObject")
 With fsoObj
  If Not .FolderExists(enddir) Then
   .CreateFolder (enddir)
  End If
 End With

Matt

[Zack Barresse]

I think Matt's got it. Dates are very tricky in Excel. The most important thing to remember when dealing with dates in VBA is that Excel see's it as a whole number, or serial number. That's it. Nothing more, nothing less. Everything that you actually see in regards to the date is a format, a mask, a covering. It will appear many ways, but in the end, Excel will still see it as only a whole number.


HTH

[brianlois]

This works great Matt!! Just what I needed. Thanks.

Would you happen to know what I could use instead of the "Name" function to move my files? I want to be able to overwrite files if they already exist in the "enddir". I didn't see an option in the "MoveFile" function to overwrite existing files.

[mvidas]

I've never actually used the Name function, in fact I never actually used the FileSearch either. Looking through your code, it looks like all you're doing is moving the excel files from startdir and startdir's subdirs to enddir. I don't really understand what you're opening the file, saving it, and closing it. Using FileSearch, you could do:

Sub FindClientExcelFiles()
Dim vaFileName As Variant
Dim startdir As String
Dim enddir As String
Dim Foo As Workbook
Dim fsoObj As Object
enddir = ("C:\Temp\" & Format(Date, "MMDDYYYY") & "\")
startdir = "C:\Temp\1"
Set fsoObj = CreateObject("Scripting.FileSystemObject")
If Not fsoObj.FolderExists(enddir) Then fsoObj.CreateFolder enddir
With Application.FileSearch
.NewSearch 'Clear old search criteria
.LookIn = startdir 'Directory to search
.SearchSubFolders = True 'Include sub folders in search
.FileType = msoFileTypeExcelWorkbooks 'Look for Excel files
.LastModified = msoLastModifiedAnyTime 'Doesn't matter when last modified
For Each vaFileName In .FoundFiles 'List the files in the 
'FoundFiles collection
Set Foo = Workbooks.Open(vaFileName)
Foo.SaveAs enddir & Foo.Name
Foo.Close
Kill vaFileName
Next vaFileName
End With
Set fsoObj = Nothing
End Sub

If I were doing it, I would use the file system object for the entire thing:

Sub FindClientExcelFiles()
Dim fso As Object
Dim startdir As String
Dim enddir As String
enddir = ("C:\Temp\" & Format(Date, "MMDDYYYY") & "\")
startdir = "C:\Temp\1"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(enddir) Then fso.CreateFolder enddir
Application.ScreenUpdating = False
ProcessFolder fso.GetFolder(startdir), fso, enddir
Application.ScreenUpdating = True
Set fso = Nothing
End Sub

Public Function ProcessFolder(fld As Object, fso As Object, ByVal eDir As String)
Dim f As File
Dim fl As Folder
For Each f In fld.Files
If LCase(Right(f.Name, 3)) = "xls" Then
If fso.FileExists(eDir & f.ShortName) Then fso.DeleteFile eDir & _ 
f.ShortName
fso.MoveFile f, eDir & f.ShortName
End If
Next
For Each fl In fld.SubFolders
ProcessFolder fl, fso, eDir
Next fl
Set f = Nothing
Set fl = Nothing
End Function

But how you choose to do it is up to you!
Matt

[Regouin]

I had figured the same thing out, by using a string to be the folders name the problem is solved

[brianlois]

Thanks Guys!! I am still having trouble with duplicate files. Is there a way to automatically overwrite duplicate files that are in the "enddir" or automatically say "yes" to the prompt of "would you like to overwrite this file"??

Sub FindClientExcelFiles()
  Dim FS As Office.FileSearch
  Dim vaFileName As Variant
  Dim startdir
  Dim enddir
  Dim Foo As Object
  Dim iCount As Long
  Dim newname As Variant
  Dim fsoObj As Object, TheDate As String
TheDate = Format(Date, "YYYYMMDD")
startdir = "C:\Temp\1"
  enddir = ("C:\Temp\" & TheDate & "\")
Set fsoObj = CreateObject("Scripting.FileSystemObject")
    With fsoObj
    If Not .FolderExists(enddir) Then
        .CreateFolder (enddir)
    End If
End With
  Set FS = Application.FileSearch
  With FS
    'Clear old search criteria
    .NewSearch
    'Directory to search
    .LookIn = startdir
    'Include sub folders in search
    .SearchSubFolders = True
    'Look for Excel files
    .FileType = msoFileTypeExcelWorkbooks
    'Doesn't matter when last modified
    .LastModified = msoLastModifiedAnyTime
    iCount = .Execute
    'List the files in the FoundFiles collection
    For Each vaFileName In .FoundFiles
Set Foo = Workbooks.Open(vaFileName)
    Foo.SaveAs enddir & Foo.Name
    Foo.Close
    Kill vaFileName
Next vaFileName
  End With
End Sub

[mvidas]

Sure, I thought I added it into the above code, but just realize I hadn't

Application.DisplayAlerts = False
            Foo.SaveAs enddir & Foo.Name
            Application.DisplayAlerts = True

Should do it!