PDA

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.