VBA copy delete files based on creation date

Hello,

I have the following vbscripts


1-Delete old files based on number days / old files

 
DossierSauvegarde = "C:\"
 
intFirstNumber = InputBox("Please enter the files preservertion number of days days /nombre de jours de conservation des fichiers:")
AgeMaximalFichiers = intFirstNumber
 
'Comptage des fichiers effaces
NbFichiersEffaces = 0
 
'Initialisation des objets
Set fso = CreateObject("Scripting.FileSystemObject" )
 
If (myName = Winrep = fso.FolderExists(DossierSauvegarde)) = False Then
    Erreur = MsgBox("Folder doesn't not exist !" )
    Wscript.Quit
End If
 
'On recupere la date système
DateSysteme = Date
 
'Suppression des fichiers trop anciens
 
Set Folder = fso.Getfolder(DossierSauvegarde)
For Each File In Folder.Files
        If (DateDiff("d", File.DateLastModified, DateSysteme) > CInt(AgeMaximalFichiers)) Then
            'On verifie qu'ils ne sont pas en lecture seule
            If File.Attributes And 1 Then File.Attributes = File.Attributes - 1
            File.Delete()
            NbFichiersEffaces = NbFichiersEffaces + 1
        End If
Next
 
MsgBox (Cstr(NbFichiersEffaces) + " files have been removed" )


2-Copy files based on old number of days / last date modified


option explicit

dim fileSystem, folder, file,AgeMaximalFichiers
dim path



path = "Y:\log\"
AgeMaximalFichiers = InputBox("Please enter the old number of days based on last date modified")
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set folder = fileSystem.GetFolder(path)




for each file in folder.Files    


           If (DateDiff("d", file.DateLastModified, Now) < CInt(AgeMaximalFichiers)) Then


  filesystem.CopyFile file, "C:\test\"

        'WScript.Echo file.Name & " last modified at " & file.DateLastModified

    end if
      
      
next

MsgBox "Process have been completed successfully"



I would like to merge all those vbscripts into a single VBA
LVL 1
LD16Asked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
ltlbearand3Connect With a Mentor Commented:
Yes.  That helps out.  I think the VBA version I posted earlier for you would have gotten you very close.  However, I went through and redid the code some to make it more clear.  The first example uses the reference and is the recommended method:

Option Explicit

Public Sub FileManage()
    ' Required References (From VBA Editor Select Tools >  References
    '  MICROSOFT SCRIPTING RUNTIME
    
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.folder
    Dim objFile As Scripting.file
    Dim intNumOfDays As Integer
    
    ' ************************************
    ' Set the Correct File Paths Here
    ' ************************************
    Const FILEDELETEPATH As String = "W:\EE Test\1\"
    Const FILECOPYFROMPATH As String = "W:\EE Test\3\"
    Const FILECOPYTOPATH As String = "W:\EE Test\1\"

    ' Instantiate File System Object
    Set objFSO = New Scripting.FileSystemObject
    
    intNumOfDays = InputBox("Enter the Number of Days for Keeping Files" & vbCrLf & "Anything older than this will be Deleted")

    If objFSO.FolderExists(FILEDELETEPATH) Then
        Set objFolder = objFSO.GetFolder(FILEDELETEPATH)
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) > CInt(intNumOfDays)) Then
                objFile.Delete (True)
            End If
        Next
        MsgBox ("Files from " & FILEDELETEPATH & " have been removed")
    Else
        MsgBox (FILEDELETEPATH & " does not exist !")
    End If
 
    intNumOfDays = InputBox("Enter the Number of Days for Moving Files" & vbCrLf & "Anything with this range this will be copied to " & FILECOPYTOPATH)
    
    Set objFolder = objFSO.GetFolder(FILECOPYFROMPATH)

    If objFSO.FolderExists(FILECOPYFROMPATH) And objFSO.FolderExists(FILECOPYTOPATH) Then
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) <= CInt(intNumOfDays)) Then
                objFile.Copy FILECOPYTOPATH, True
            End If
        Next
        MsgBox (" Files modified with then last " & intNumOfDays & " have been copied from " & vbCrLf & FILECOPYFROMPATH & " to " & FILECOPYTOPATH)
    Else
        MsgBox "Missing File Path.  Either " & FILECOPYTOPATH & " or " & FILECOPYFROMPATH & " is missing"
    End If

    MsgBox "Process have been completed successfully"
                                          
End Sub
                                          
Option Explicit

Open in new window


This second one uses late binding and does not require the reference:
Public Sub FileManageLateBine()
    ' Required References (From VBA Editor Select Tools >  References
    '  MICROSOFT SCRIPTING RUNTIME
    
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim intNumOfDays As Integer
    
    ' ************************************
    ' Set the Correct File Paths Here
    ' ************************************
    Const FILEDELETEPATH As String = "W:\EE Test\1\"
    Const FILECOPYFROMPATH As String = "W:\EE Test\3\"
    Const FILECOPYTOPATH As String = "W:\EE Test\1\"

    ' Instantiate File System Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    intNumOfDays = InputBox("Enter the Number of Days for Keeping Files" & vbCrLf & "Anything older than this will be Deleted")

    If objFSO.FolderExists(FILEDELETEPATH) Then
        Set objFolder = objFSO.GetFolder(FILEDELETEPATH)
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) > CInt(intNumOfDays)) Then
                objFile.Delete (True)
            End If
        Next
        MsgBox ("Files from " & FILEDELETEPATH & " have been removed")
    Else
        MsgBox (FILEDELETEPATH & " does not exist !")
    End If
 
    intNumOfDays = InputBox("Enter the Number of Days for Moving Files" & vbCrLf & "Anything with this range this will be copied to " & FILECOPYTOPATH)
    
    Set objFolder = objFSO.GetFolder(FILECOPYFROMPATH)

    If objFSO.FolderExists(FILECOPYFROMPATH) And objFSO.FolderExists(FILECOPYTOPATH) Then
        For Each objFile In objFolder.Files
            If (DateDiff("d", objFile.DateLastModified, Date) <= CInt(intNumOfDays)) Then
                objFile.Copy FILECOPYTOPATH, True
            End If
        Next
        MsgBox (" Files modified with then last " & intNumOfDays & " have been copied from " & vbCrLf & FILECOPYFROMPATH & " to " & FILECOPYTOPATH)
    Else
        MsgBox "Missing File Path.  Either " & FILECOPYTOPATH & " or " & FILECOPYFROMPATH & " is missing"
    End If

    MsgBox "Process have been completed successfully"
                                          
End Sub

Open in new window

0
 
ltlbearand3Commented:
Are you wanting the two scripts to use the same date selection?  Try something like this:

option explicit

dim fso, folder, file, AgeMaximalFichiers, DateSysteme
dim strLogPath, DossierSauvegarde, NbFichiersEffaces


strLogPath = "Y:\log\"
DossierSauvegarde = "C:\"

'Initialisation des objets
Set fso = CreateObject("Scripting.FileSystemObject")

AgeMaximalFichiers = InputBox("Please enter the files preservertion number of days days /nombre de jours de conservation des fichiers:")
 
'Comptage des fichiers effaces
NbFichiersEffaces = 0
 
 
If Not fso.FolderExists(DossierSauvegarde) Then
    MsgBox("Folder doesn't not exist !" )
    Wscript.Quit
End If
 
'On recupere la date système
DateSysteme = Date
 
'Suppression des fichiers trop anciens
 
Set Folder = fso.Getfolder(DossierSauvegarde)
For Each File In Folder.Files
        If (DateDiff("d", File.DateLastModified, DateSysteme) > CInt(AgeMaximalFichiers)) Then
            'On verifie qu'ils ne sont pas en lecture seule
            If File.Attributes And 1 Then File.Attributes = File.Attributes - 1
            File.Delete()
            NbFichiersEffaces = NbFichiersEffaces + 1
        End If
Next
 
MsgBox (Cstr(NbFichiersEffaces) + " files have been removed" ) 

Set folder = fso.GetFolder(strLogPath)

for each file in folder.Files    
	If (DateDiff("d", file.DateLastModified, Now) < CInt(AgeMaximalFichiers)) Then
		filesystem.CopyFile file, "C:\test\"
		'WScript.Echo file.Name & " last modified at " & file.DateLastModified
	end if
next

MsgBox "Process have been completed successfully"

Open in new window

0
 
LD16Author Commented:
Hello, the date selection can be different. Aditionnally I would like to launch those scripts with Excel Vba and review the entire code to make it suitable with Excel VBA.
0
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
ltlbearand3Commented:
Give this a shot in VBA.  You will need to make sure you add a reference to the project for Microsoft Scripting Runtime.

Option Explicit

Public Sub FileManage()
    ' Required References
    '  MICROSOFT SCRIPTING RUNTIME
    
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.folder
    Dim objFile As Scripting.file
    Dim AgeMaximalFichiers As Integer
    Dim NbFichiersEffaces As Integer
    Dim strLogPath As String
    Dim DossierSauvegarde As String
    
    strLogPath = "Y:\log\"
    DossierSauvegarde = "C:\"

    'Initialisation des objets
    Set objFSO = New Scripting.FileSystemObject

    AgeMaximalFichiers = InputBox("Please enter the files preservertion number of days days /nombre de jours de conservation des fichiers:")
 
    'Comptage des fichiers effaces
    NbFichiersEffaces = 0
 
    If objFSO.FolderExists(DossierSauvegarde) Then
        Set objFolder = objFSO.GetFolder(DossierSauvegarde)
        For Each objFile In objFolder.Files
                If (DateDiff("d", objFile.DateLastModified, Date) > CInt(AgeMaximalFichiers)) Then
                    'On verifie qu'ils ne sont pas en lecture seule
                    If objFile.Attributes And 1 Then objFile.Attributes = objFile.Attributes - 1
                    objFile.Delete (True)
                    NbFichiersEffaces = NbFichiersEffaces + 1
                End If
        Next
         
        MsgBox (CStr(NbFichiersEffaces) + " files have been removed")
    Else
        MsgBox (DossierSauvegarde & " does not exist !")
    End If
 
    AgeMaximalFichiers = InputBox("Please enter the old number of days based on last date modified")
    
    'Suppression des fichiers trop anciens
    Set objFolder = objFSO.GetFolder(strLogPath)

    For Each objFile In objFolder.Files
        If (DateDiff("d", objFile.DateLastModified, Date) < CInt(AgeMaximalFichiers)) Then
            objFSO.CopyFile objFile.Name, "C:\test\"
            'WScript.Echo file.Name & " last modified at " & file.DateLastModified
        End If
    Next

    MsgBox "Process have been completed successfully"
                                          
End Sub

Open in new window

0
 
LD16Author Commented:
Hello,

How can I add the Microsoft Scripting runtime, Do I need to download a library or just make the set up in Excel?
I have a Excel 2007 Version.

Thank  you.
0
 
LD16Author Commented:
I found the following code which works in VBA:

Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath.
'You can also use this to copy the files from the last ? days
'If Fdate >= Date - 30 Then
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object

    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
        If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub
0
 
ltlbearand3Commented:
That uses late binding, but in VBA it is better to add the reference.  To add a reference, in the VBA editor select tools >> references and then select Microsoft Scripting Runtime.

The second script will not prompt for the date, the first one does.  It just depends on what you want the script to actually accomplish.
0
 
LD16Author Commented:
Hello Itibearnd,

I tried to prompt the date with the second script and is not working properly even if I don't have an error message. could please tell me wh

Here is what I use :

Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath.
'You can also use this to copy the files from the last ? days
'If Fdate >= Date - 30 Then
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
    Dim FSO As Object
    Dim FromPath, olddate  As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object



    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change
   olddate = InputBox("Enter the number of days",,1)


    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If Fdate >= Date & " -  "  & olddate  Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub
0
 
ltlbearand3Commented:
LD16,

When you post code, please use the "Code" button on the Comment toolbar.  It makes code much easier to read.  Also, could you please tell me what you want.  I answered the original question to combine the scripts, but that does not seem to be what you want.  I can help you out much better if you tell me what you want.

Now in your last posted script, you try to get the new date buy subtracting dates.  That will not work.  You need to use the DateDiff function like this:
    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If (DateDiff("d", FileInFromFolder.DateLastModified, Date) > CInt(olddate)) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

Open in new window



However, note that making that change will not result in the same thing as the combination of your two original scripts.
0
 
LD16Author Commented:
@Itiberands,

My mystakes, I haven't specify properly what I want.
This is the revised specs.

1-Delete the various files from the last ? days, I suppose that your following loop can perform this requirement:

 For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If (DateDiff("d", FileInFromFolder.DateLastModified, Date) > CInt(olddate)) Then
            FileInFromFolder.Delete
        End If
    Next FileInFromFolder

Open in new window


2-Copy files from the last ? days:

 
  For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
      If (DateDiff("d", FileInFromFolder.DateLastModified, Date) > CInt(olddate2)) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

Open in new window


This script will need two inputbox, the one for olddate and the other for olddate2.

Is it clearer for you?
0
 
LD16Author Commented:
Great! I have tested and both solutions work perfectly
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.