PDA

View Full Version : [SOLVED] Create new directory for today's date



brianlois
03-02-2005, 07:03 AM
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
03-02-2005, 07:30 AM
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
03-02-2005, 08:24 AM
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
03-02-2005, 09:04 AM
mmm cant get it to work right now, I'll see if I can work around it later

mvidas
03-02-2005, 09:32 AM
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
03-02-2005, 09:59 AM
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
03-02-2005, 10:29 AM
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
03-02-2005, 11:11 AM
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
03-03-2005, 12:26 AM
I had figured the same thing out, by using a string to be the folders name the problem is solved

brianlois
03-03-2005, 09:36 AM
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
03-03-2005, 10:52 AM
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!