Move all except latest to another folder

  • Thread starter Thread starter DavidH56
  • Start date Start date
D

DavidH56

Hi,

I found the following code posted by Ron Debruin to delete all files except
most recent within a folder. What I'd like to do is to move all except the
most recent excel file from the current folder to the archives folder leaving
the most recent excel file. There may be more file types than excel within
the current folder.

Function NewestFile(Directory, FileSpec)
' John Walkenbach
' http://www.j-walk.com/ss/excel/tips/tip97.htm
' Returns the name of the most recent file in a Directory
' That matches the FileSpec (e.g., "*.xls").
' Returns an empty string if the directory does not exist or
' it contains no matching files
Dim FileName As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
FileName = Dir(Directory & FileSpec, 0)
If FileName <> "" Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(Directory & FileName)
Do While FileName <> ""
If FileDateTime(Directory & FileName) > MostRecentDate Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(Directory & FileName)
End If
FileName = Dir
Loop
End If
NewestFile = MostRecentFile
End Function

Sub Kill_All_Old_Files_in_Folder()
Dim Folder As String
Dim str1 As String
Dim str2 As String
Folder = "c:\Data\"
str1 = NewestFile(Folder, "*.xls")
str2 = Folder & str1
If str1 <> "" Then
Name str2 As Left(str2, Len(str2) - 4) & ".rdb"
On Error Resume Next
Kill Folder & "*.xls"
On Error GoTo 0
Name Left(str2, Len(str2) - 4) & ".rdb" As str2
End If
End Sub

Thanks in advance for your help.
 
If your question is how to move the files instead of deleting them
then try method 'Name' in vba help.
Note that it's METHOD and not a PROPERTY.
 
Thanks AB for your response. I did lookup create names, list names and apply
names methods. i finally developed additional modications to the one I
previously posted. It seems to work for me. please see below.

Option Explicit

Function NewestFile(Directory, FileSpec)
' John Walkenbach
' http://www.j-walk.com/ss/excel/tips/tip97.htm
' Returns the name of the most recent file in a Directory
' That matches the FileSpec (e.g., "*.xls").
' Returns an empty string if the directory does not exist or
' it contains no matching files
Dim FileName As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
FileName = Dir(Directory & FileSpec, 0)
If FileName <> "" Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(Directory & FileName)
Do While FileName <> ""
If FileDateTime(Directory & FileName) > MostRecentDate Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(Directory & FileName)
End If
FileName = Dir
Loop
End If
NewestFile = MostRecentFile
End Function
Sub Move_All_Old_Files_in_Folder()
Dim Folder As String
Dim str1 As String
Dim str2 As String
Folder = "J:\Test\Current"
str1 = NewestFile(Folder, "*.xls")
str2 = Folder & str1
If str1 <> "" Then
Name str2 As Left(str2, Len(str2) - 4) & ".rdb"
On Error Resume Next
MoveOldiesToArchives
On Error GoTo 0
Name Left(str2, Len(str2) - 4) & ".rdb" As str2
End If
End Sub
Sub MoveOldiesToArchives()
Dim FSO
Dim sfol As String, dfol As String
sfol = "J:\Test\Current" ' change to match the source folder path
dfol = "J:\Test\Archives" ' change to match the destination folder path
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If Not FSO.FolderExists(sfol) Then
MsgBox sfol & " is not a valid folder/path.", vbInformation, "Invalid
Source"" ElseIf Not fso.FolderExists(dfol) Then"
MsgBox dfol & " is not a valid folder/path.", vbInformation, "Invalid
Destination """
Else
FSO.MoveFile (sfol & "\*.xls"), dfol ' Change "\*.*" to "\*.xls" to move
Excel Files only
End If
If Err.Number = 53 Then MsgBox "File not found"
End Sub

Thanks again for your response.
 
Back
Top