View Full Version : VBA too long-winded help needed.
gint32
01-13-2018, 11:16 PM
Hi,
I have finally managed to string together (with a lot of help of-course) VBA that essentially archives the latest excel file in each folder that was created less than the date ran ie:-todays date, but my VBA is terrible so when I step through the code it its all over the place and very slow when there are lots of folders with hundreds of files, I was hoping that a guru could suggest a more efficient way to do the exact same or just clean up so it would run faster, this would suit me and any others that need a similar system for backups. many thanks in advance for any suggestions
Option Explicit
Sub Findfolders()
Dim FileSystem As Object
Dim Hostfolder1 As String
Dim fso As Scripting.FileSystemObject
Hostfolder1 = "P:\Management\Industries Control\Archives\Temp\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder1 FileSystem.GetFolder(Hostfolder1)
End Sub
Sub DoFolder1(Folder)
Dim subfolder
Dim FolderName1 As String
Dim LCF As Date
Dim todays_date As Date
Dim fld As Scripting.Folder
Dim FileSystem As Object
todays_date = Format(Date, "DD-MMm-YY")
For Each subfolder In Folder.SubFolders
'MsgBox SubFolder
DoFolder1 subfolder
LCF = VBA.DateValue(subfolder.DateCreated)
If LCF < todays_date Then
FolderName1 = subfolder
Call IndCtl_FindNewestFile(FolderName1)
ElseIf LCF >= todays_date Then
' MsgBox "Greater than todays date" & vbNewLine & " Do nothing and exit sub"
' Exit Sub
End If
Next
'Set fld = Nothing
'Set fso = Nothing
End Sub
Sub IndCtl_FindNewestFile(FolderName1 As String)
Dim MyPath As String
Dim subfolder As String
'Dim FolderName1 As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LCF As Date
Dim DestinationFolder As String
Dim dt_today As Variant
dt_today = Format(Date, "DD-MMm-YY")
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
MyPath = FolderName1
DestinationFolder = "P:\Management\Industries Control\Archived\"
'may need to append todays date on end
'so each folder (date named) contain one LCD archived file
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' Check and add a backslash \ if not already got one
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "*.xlsm", vbNormal)
If Len(MyFile) = 0 Then
' MsgBox "No files were found…", vbExclamation
Exit Sub
End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Do While Len(MyFile) > 0 'loop through each file and get Last created Date
LCF = FileDateTime(MyPath & MyFile)
If LCF > LatestDate Then 'DT_Today
LatestFile = MyFile
LatestDate = LCF 'latest created (and not the modified date)
End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
MyFile = Dir
Loop
'move the LCF file to the archived folder
dt_today = Format(Now, "DD-MMm-YY")
DestinationFolder = DestinationFolder & dt_today & "\"
' MsgBox DestinationFolder
If Dir(DestinationFolder, vbDirectory) = "" Then
MkDir DestinationFolder
End If
FileCopy MyPath & LatestFile, DestinationFolder & LatestFile
'If Len(MyFile) > 0 Then
Kill MyPath & "*.*"
RmDir MyPath
End Sub
Logit
01-14-2018, 01:21 PM
.
Option Explicit
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
'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\logit\Desktop\Test1\" '<< Change
ToPath = "C:\Users\logit\Desktop\Test2\" '<< 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)
'Set date range here :
If Fdate >= DateSerial(2017, 11, 1) And Fdate <= DateSerial(2018, 1, 20) Then
FileInFromFolder.Copy ToPath
Kill FileInFromFolder
End If
Next FileInFromFolder
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
This macro can be edited to incorporate two Input boxes asking for a FROM and TO date. That way the date range won't be "hard coded", or it can be modified to look at anything less than the current date.
gint32
01-14-2018, 09:05 PM
.
This macro can be edited to incorporate two Input boxes asking for a FROM and TO date. That way the date range won't be "hard coded", or it can be modified to look at anything less than the current date.
Thanks for the suggestion but the vba that you suggested copies all files from one folder to another and is not quit what I was looking for, I'll try and give more detailed explanation as to what I was looking for was ....I have VBA that presently essentially archives the latest excel file in each folder that's older than today's date. Here is the reason... I have an excel file that essentially serves as a template of sorts, because the moment that user who opens it each morning every morning and makes any change to it, the code within the On -Change Event will then action and save the file to a new file it does this by appending today date and time to it and then it saves to a folder named with todays date (ie 15Jan2018), so at the end of each day each of the folderers created will have lots of xlsm files, But I am only interested in archiving or catching the latest last appended XLSM file in that folder (and each folder that was created). So the code I supplied in the OP does do the job I need, but as I said its slow and appears to me to be very cumbersome so I just need the OP VBA to run faster, thats if it is possible although if this can't be done ie making my OP VBA run any quicker than it already does, then thats fine and I'll just put up with it, but please just let me know Either-way. Many thanks for taking the time to read.
Logit
01-14-2018, 10:09 PM
For curiosity sake ... on average, how many workbooks and how many folders are you dealing with .. and .. how long does it take ?
My apologies for not fully understanding your needs. I'll look again.
gint32
01-14-2018, 10:16 PM
Thanks, probably by the end of any given day there are 100 - 150 ish in that days folder shouldn't be that many in any other as the will have presumably been already archived as I plan to run this on open once I figure out how to accomplish this, I havn't had much luck so far though. So need to manually do this at present every few days when I remember.
Really depends on many factors so its hard to say based on file sizes And also how fast the network is at the current time, others streaming and running huge reports etc!
Thanks any other questions,
georgiboy
01-15-2018, 08:10 AM
How about something like this:
Sub FileDelete()
Dim FileLoc As String, ArchiveLoc As String, DaysOlderThan As Long, dte As String, x As Long
dte = Format(Now(), "dd-mm-yy") 'change to suit
FileLoc = ThisWorkbook.Path & "\test" 'change to suit
ArchiveLoc = ThisWorkbook.Path & "\test2\" & dte 'change to suit
DaysOlderThan = 1 'change to suit
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each fcount In FSO.GetFolder(FileLoc).Files
If DateDiff("d", fcount.DateCreated, Now()) > DaysOlderThan Then
On Error Resume Next
MkDir (ArchiveLoc)
Name fcount As ArchiveLoc & "\" & fcount.Name
x = x + 1
End If
Next fcount
MsgBox "Archived: " & x & " files"
End Sub
Hope this helps
Logit
01-15-2018, 04:45 PM
.
gint32
Here is the macro and an attached example workbook. You will need to change the paths in the macro to comply with your system. They are all marked with something similar to:
'<< Change path to COPY TO folder <---//////\\\\\\
#1 - This macro will first check to make certain the folder where the files/folders are being COPIED TO is empty. This will prevent errors trying to copy files/folders with the same name. It first will delete all the files/folders
with in COPY TO folder before doing anything else.
#2 - Then the macro reviews the COPY FROM folder and identifies all of the files that are older than TODAY minus 1 day.
#3 - Those identified files are then copied to the COPY TO folder and the files/folders that were just copied are deleted from the COPY FROM folder.
I suspect there is a part of the macro that probably doesn't quite fit the bill for your purposes. If you will advise what part we can edit it and move forward.
This macro will function if your subfolders are one within the other ... or if there are several folders by themselves all sitting separately within the main folder.
I tested and retested this numerous times here. You should not have any issues with it.
Let me know ...
Option Explicit
Sub Clear_All_Files_And_SubFolders_In_Folder()
'Delete all files and subfolders in the TARGET FOLDER
'Be sure that no file is open in the folder
Dim FSO As Object
Dim MyPath As String
Set FSO = CreateObject("scripting.filesystemobject")
MyPath = "C:\Users\logit\Desktop\Test2" '<< Change path to COPY TO folder <---//////\\\\\\
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
On Error Resume Next
'Delete files
FSO.DeleteFile MyPath & "\*.*", True
'Delete subfolders
FSO.deletefolder MyPath & "\*.*", True
On Error GoTo 0
'Now we will get on with the copying process
PerformCopy
End Sub
Sub PerformCopy()
'<< Change path as required. First on left is the COPY FROM folder; the second on RIGHT <---//////\\\\\\
'<< Is the COPY TO folder
CopyFiles "C:\Users\logit\Desktop\Test1" & "\", "C:\Users\logit\Desktop\Test2" & "\"
End Sub
Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
Dim FSO As Object
Dim FileInFromFolder As Object
Dim FolderInFromFolder As Object
Dim Fdate As Long
Dim intSubFolderStartPos As Long
Dim strFolderName As String
Dim dirStr As String
Dim ToFolder As String
Dim DeleteFile
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
ToFolder = "C:\Users\logit\Desktop\Test2" '<< Change path as required.This is the COPY TO folder
'First loop through files
For Each FileInFromFolder In FSO.GetFolder(strPath).Files
Fdate = Int(FileInFromFolder.DateLastModified)
If Fdate < Date - 1 Then
FileInFromFolder.Copy strTarget
Kill FileInFromFolder
End If
Next
'Next loop throug folders
For Each FolderInFromFolder In FSO.GetFolder(strPath).subfolders
CopyFiles FolderInFromFolder.Path & "\", strTarget & "\" & strFolderName & "\"
For Each FileInFromFolder In FSO.GetFolder(strPath).Files
Fdate = Int(FileInFromFolder.DateLastModified)
If Fdate < Date - 1 Then
FileInFromFolder.Copy strTarget
End If
Next
Next
'Now delete all empty folder in the FROM Folder
For Each FolderInFromFolder In FSO.GetFolder(strPath).subfolders
RmDir FolderInFromFolder
Next
End Sub
gint32
01-16-2018, 06:13 AM
Thanks for your VBA, you must have spent a fair bit of time on this, I stepped through it correct me if i am wrong but it seems that
If Fdate < Date - 1 Then does not have a date value but a number value that checks against a date value ,so may always be less than < DATE, also my vba that saves these workbooks on change creates a new folder for each day it is amended. before it saves.
The whole idea of archiving is to have an archive of past records so I never want to clear out any archived folders ,so not sure why you encoded [CODE] 'Delete files
FSO.DeleteFile MyPath & "\*.*", True
'Delete subfolders
FSO.deletefolder MyPath & "\*.*", True
On Error GoTo 0
But regardless really thats easy for me to comment out..
What i am looking for and my OP code does do this this is find each SUBfolder and look WITHIN for the latest created file *.XLSM and when it find it then only Archive this file and delete the rest of the files within each of the subfolders.
my subfolders are named 1_Dec_2017, 2_Dec_2018 3_Dec_2017 etc,
Each folder will have 100-150 XLSM files, so I was looking for a way of reading in the Created dates of these files quicker EG ...then ascertaining the latest created(not modified) into an array or whatever is quicker than looping then archive then delete the rest then move on to the next.
I think it best understood if someone steps through my code first and then they may see a way to improve speed. Thanks
Many thanks for your patience with this
gint32
01-16-2018, 01:58 PM
Perhaps it will be better understood if I give the logic to this.
1. Find all (folders with the subfolder) .. \Temp\
a. ..\Temp\26Dec2017\
b. ..\Temp\27Dec2017\
c. ..\Temp\28Dec2017\
d. ..\Temp\29Dec2017\
e. ..\Temp\30Dec2017 \
Const parentFolder As String = "P:\management\Industries Control\Archives\temp\"
2. Search, List or Get the dates created from each of the (subfolders with the folder).. \Temp\
3. IF the date created of any these (subfolders with the folder …\Temp\ ) is less than todays date THEN
4. Retain the subfolders name (set tmpVariable for this) Then
5. List all the XLSM files within this subfolder and delete all of them except the last created file
6. If not exist create a subfolder named the (retained name) in the destination folder \Archived\ Then
7. Move (or Copy)the last created XLSM file to this folder(retained name) within the archived directory .. \Archived\ .. tmpVariable..
8. Now delete the subfolder in ../Temp/
9. Move on to the next subfolder and repeat the process till all subfolders have been deleted except for that days subfolder
Correct me if I am wrong , But I am not sure but I read that a really fast way of listing many files in a directory was to shell out to Dos
Some like
results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.*"" /T:C /O:-D").StdOut.ReadAll |find "/"
gint32
01-16-2018, 04:19 PM
My Apologies, I must have been tired or ??? as looking at your suggested code it almost works a treat and as such I'll be able to adjust as necessary...many thanks for taking the time to evaluate and recode.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.