Consulting

Results 1 to 10 of 10

Thread: VBA too long-winded help needed.

  1. #1
    VBAX Regular
    Joined
    Jan 2015
    Posts
    42
    Location

    VBA too long-winded help needed.

    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

  2. #2
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    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.
    Attached Files Attached Files

  3. #3
    VBAX Regular
    Joined
    Jan 2015
    Posts
    42
    Location

    Not quit what I meant, but thanks :)

    Quote Originally Posted by Logit View Post
    .

    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.

  4. #4
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    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.

  5. #5
    VBAX Regular
    Joined
    Jan 2015
    Posts
    42
    Location
    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,
    Last edited by gint32; 01-15-2018 at 02:25 AM.

  6. #6
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    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
    Last edited by georgiboy; 01-15-2018 at 09:24 AM.
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  7. #7
    VBAX Expert Logit's Avatar
    Joined
    Sep 2016
    Posts
    606
    Location
    .
    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
    Attached Files Attached Files

  8. #8
    VBAX Regular
    Joined
    Jan 2015
    Posts
    42
    Location

    loop subfolders files and find the latest created file then archive each one.

    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

  9. #9
    VBAX Regular
    Joined
    Jan 2015
    Posts
    42
    Location

    The Process logically

    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 "/"

  10. #10
    VBAX Regular
    Joined
    Jan 2015
    Posts
    42
    Location
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •