Moster code with monster help

Ed in Aus

Well-known Member
Joined
Jul 24, 2007
Messages
829
Here is the goal to archive all files and folders greater than 5 years, I have got the list from using some code that basically list all files folders and attributes (can post if anyone is interested...

what i have done now is created a list of anything that is older than 5 years since it has been modified.

the only thing is the list had the whole file path so i wanted to shorten that down:

e.g had L:\Administration\Reports\2001-2002 - Reports\End December 2000 Monthly Report.xls
and basically split that over some rows using data -> text to columns -> then delimited with the "\" and removed the first part "L:\"

now what i want to do is move the files to and archive folder, I was thinking along the line of something that checks the cell if it contains not "." then create the folder in the archive folder if the folder exists then move right to the next cell, same logic check if there is a "."... if there is a "." then move that file into the previously created folder.

Is anyone following this??? I am having one of those days that never end
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Just understood bits and pieces. If you tell me where your files are and where you need them transferred to with the full path the I can write a code for you with the option of checking if its 5 yrs old.
 
Upvote 0
Thats part of my problem... what I eneded up doing was very complex but works non the less...

I will just post some of the code for you to have a look at then you can see the logic i have used, and please if you can see a cleaner faster way please let me know i am self taught and some of the coding i have picked up is bad practice.

What I like about this is no matter where you store it you will get the files listed from there and below... change the subfolder part if you only want current directory (could add a msgbox to do this but didn't need to yet)

Code:
Sub ListFilesInFolder1()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "Document Name"
    Range("B3").Formula = "File Name:"
    Range("C3").Formula = "File Size:"
    Range("D3").Formula = "File Type:"
    Range("E3").Formula = "Date Created:"
    Range("F3").Formula = "Date Last Accessed:"
    Range("G3").Formula = "Date Last Modified:"
    Range("H3").Formula = "Attributes:"
    Range("I3").Formula = "Short File Name:"
    Range("A3:I3").Font.Bold = True
    ListFilesInFolder ActiveWorkbook.Path, True
    ' list all files included subfolders
End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A65536").End(xlUp).Row + 1
    For Each FileItem In SourceFolder.Files
        ' display file properties
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = FileItem.Path
        Cells(r, 3).Formula = FileItem.Size
        Cells(r, 4).Formula = FileItem.Type
        Cells(r, 5).Formula = FileItem.DateCreated
        Cells(r, 6).Formula = FileItem.DateLastAccessed
        Cells(r, 7).Formula = FileItem.DateLastModified
        Cells(r, 8).Formula = FileItem.Attributes
        Cells(r, 9).Formula = FileItem.ShortPath & FileItem.ShortName
        ' use file methods (not proper in this example)
'        FileItem.Copy "C:\FolderName\Filename.txt", True
'        FileItem.Move "C:\FolderName\Filename.txt"
'        FileItem.Delete True
        r = r + 1 ' next row number
    Next FileItem
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
    Columns("A:I").AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub

So here is the next part which basically rats out anythin older than 5 years old, had to use modified cause our IT guys have accessed all of them recently.

Code:
Sub Setting_up()
'
' Macro9 Macro
' Macro recorded 24/03/2009 by eddyc
'

'

    Range("J3").Activate
    Range("J3").Value = "Filter"
    ActiveCell.Offset(1, 0).Activate
    ActiveCell.FormulaR1C1 = "=IF(NOW()-R[1]C[-3]>365*5,""Yes"","""")"
    Cells(4, 1).Activate
    Selection.End(xlDown).Select
    r = ActiveCell.Row
    
    Range("j4").Select
    Selection.Copy
    Range("J4:J" & r).Select
    ActiveSheet.Paste
    
    Cells.Select
    Cells.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    
    Rows("3:3").Select
    Selection.AutoFilter
    
    Selection.AutoFilter Field:=10, Criteria1:="="
    Rows("4:4").Select
    
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    
    Rows("3:3").Select
    Selection.AutoFilter

    Range("A:A,C:F,H:I").Delete
    
    Rows("1:2").Delete

    Range("B1").Value = "First"
    Range("C1").Value = "second"
    Range("D1").Value = "third"
    Range("E1").Value = "fourth"
    Range("F1").Value = "fifth"
Application.DisplayAlerts = False
    Cells.Replace What:="L:\", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Selection.Delete Shift:=xlToLeft

End Sub

And now for the final part the archiving bit (my favourite) cause its so messy but works a treat.

Code:
Sub archive()
'First we need to start at column 6 work to the left to find the file to move
'Then we need to create the folder based on what is to the left
Dim r, c As Integer
Dim networking As String
Dim MyTimer As Double
MyTimer = Timer
r = 2
c = 1
    
Do Until Cells(r, 1) = ""

Cells(r, 1).Select
If ActiveCell.Value Like "*$*" Then GoTo bump
If ActiveCell.Value Like "*.*" Then GoTo skippy
    'First Folder needs to be done this way once then to loop
    'Basically it is setting up the base network folder to network variable
    If Len(Dir(("L:\Archive\" & ActiveCell.Value & "\"), vbDirectory)) = 0 Then
    MkDir ("L:\Archive\" & ActiveCell.Value)
    networking = "L:\Archive\" & ActiveCell.Value & "\"
    ActiveCell.Offset(0, 1).Activate
    Else
    networking = "L:\Archive\" & ActiveCell.Value & "\"
    ActiveCell.Offset(0, 1).Activate
    End If
    

Do Until ActiveCell = ""
        'Second Folder
If ActiveCell.Value Like ("*$*") Then GoTo bump
If ActiveCell.Value Like "*.*" Then GoTo skippy
        If Len(Dir(networking & ActiveCell.Value, vbDirectory)) = 0 Then
        MkDir networking & ActiveCell.Value
        networking = networking & ActiveCell.Value & "\"
        ActiveCell.Offset(0, 1).Activate
        Else
        networking = networking & ActiveCell.Value & "\"
        ActiveCell.Offset(0, 1).Activate
        End If
Loop
skippy:
FLname = ActiveCell
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
'Dim r As Long
    Set FSO = New Scripting.FileSystemObject
'    MsgBox (ActiveCell.Column)
'    ActiveCell.Select
'    FileItem = ActiveCell.Value
'    ActiveCell.Offset(0, -1).Select
    network1 = ""
Do Until ActiveCell.Column = 1
    network1 = "\" & ActiveCell.Value & network1
    ActiveCell.Offset(0, -1).Activate
Loop
network1 = "L:\" & ActiveCell + network1
    
    comb = networking & FLname
    FileCopy network1, comb
    MsgBox network1 & " has been copied to " & vbNewLine & vbNewLine & comb, , "Complete"
    Kill network1
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing

bump:
networking = ""
r = r + 1
Loop

MsgBox (Timer - MyTimer) / 60 & " Minutes"
MsgBox "Archiving complete", , "All done"
End Sub

So any suggestions to tidy up, streamline or fix????
 
Upvote 0
Here is the code you need.

Just 3 things to remember

1) When you are setting the source and destination folder you will have to give the path ending with a \ slash. If you miss this then you will get an error and some files may get copied to a different location.

Give it exactly like this.

SourceFolder = "C:\MySource\"
DestinationFolder = "C:\MyDestination\"

and NOT LIKE this.

SourceFolder = "C:\MySource"
DestinationFolder = "C:\MyDestination"

2) There is a line in the code with says

objFile.Copy (DestinationFolder & "\" & Mid(objFile.ParentFolder, LengthOfSrcFolder + 1, Len(objFile.ParentFolder)) & "\"), OverWriteFiles:=True

If you wish to overwrite existing files then leave it as it is. Otherwise change OverWriteFiles:=False

I have marked both options in red in the main code.

3) You need to be running the macro ArchiveAllFiles() to start the archive process.

If you have any questions give me a shout.

Rich (BB code):
Option Explicit
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public SourceFolder As String
Public DestinationFolder As String
Public LengthOfSrcFolder As Integer
Public LengthOfDestFolder As Integer
Public FolderPath As String
Sub ArchiveAllFiles()
    Dim MyFile As File
    SourceFolder = "C:\MySource\"
   DestinationFolder = "C:\MyDestination\"
Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set objFolder = objFSO.GetFolder(SourceFolder)
    LengthOfSrcFolder = Len(SourceFolder)
    LengthOfDestFolder = Len(DestinationFolder)
    For Each MyFile In objFolder.Files
        Set objFile = objFSO.GetFile(MyFile)
        ProcessFile objFile.Path
    Next
    ProcessSubFolder objFSO.GetFolder(SourceFolder)
End Sub
Sub ProcessFile(MyFile)
    Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set objFile = objFSO.GetFile(MyFile)
    If DateValue(objFile.DateLastModified) < DateAdd("yyyy", -5, Now()) Then
        CreateFolderStructure DestinationFolder & Mid(objFile.ParentFolder, LengthOfSrcFolder + 1, Len(objFile.ParentFolder))
        objFile.Copy (DestinationFolder & "\" & Mid(objFile.ParentFolder, LengthOfSrcFolder + 1, Len(objFile.ParentFolder)) & "\"), OverWriteFiles:=True
    End If
End Sub
Sub CreateFolderStructure(ThisFolder)
    Dim objFldr As Object
    Dim i As Integer
    FolderPath = ""
    For i = 1 To Len(ThisFolder)
        FolderPath = FolderPath & Mid(ThisFolder, i, 1)
        If Mid(ThisFolder, i, 1) = "\" Or i = Len(ThisFolder) Then
            If Not objFSO.FolderExists(FolderPath) Then
                Set objFldr = objFSO.CreateFolder(FolderPath)
            End If
        End If
    Next
End Sub
Sub ProcessSubFolder(ThisFolder)
    Dim SubFolder
    For Each SubFolder In ThisFolder.SubFolders
        Set objFolder = objFSO.GetFolder(SubFolder.Path)
        For Each objFile In objFolder.Files
            ProcessFile objFile.Path
        Next
        ProcessSubFolder SubFolder
    Next
End Sub
 
Last edited:
Upvote 0
Got one error...
Code:
 Dim MyFile As File

Also how do you change the colour for sections in code say bold or red for future referance?
 
Upvote 0
To change colour you have the font icon which is marked with letter A with a black line underneath. You will find this between the title and message section of your post. Just highlight the section you want to change colour and then click on the button. Its next to smiley icon, on top (not right).

To get this program to work can you change the line

Dim MyFile as File

to just

Dim MyFile

as shown below.

Can you post me the results immediately, its almost time for bed here.

Code:
Option Explicit
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public SourceFolder As String
Public DestinationFolder As String
Public LengthOfSrcFolder As Integer
Public LengthOfDestFolder As Integer
Public FolderPath As String
Sub ArchiveAllFiles()
    Dim MyFile
    SourceFolder = "C:\Source\"
    DestinationFolder = "C:\Destination\"
    Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set objFolder = objFSO.GetFolder(SourceFolder)
    LengthOfSrcFolder = Len(SourceFolder)
    LengthOfDestFolder = Len(DestinationFolder)
    For Each MyFile In objFolder.Files
        Set objFile = objFSO.GetFile(MyFile)
        ProcessFile objFile.Path
    Next
    ProcessSubFolder objFSO.GetFolder(SourceFolder)
End Sub
Sub ProcessFile(MyFile)
    Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set objFile = objFSO.GetFile(MyFile)
    If DateValue(objFile.DateLastModified) < DateAdd("yyyy", -5, Now()) Then
        CreateFolderStructure DestinationFolder & Mid(objFile.ParentFolder, LengthOfSrcFolder + 1, Len(objFile.ParentFolder))
        objFile.Copy (DestinationFolder & "\" & Mid(objFile.ParentFolder, LengthOfSrcFolder + 1, Len(objFile.ParentFolder)) & "\"), OverWriteFiles:=True
    End If
End Sub
Sub CreateFolderStructure(ThisFolder)
    Dim objFldr As Object
    Dim i As Integer
    FolderPath = ""
    For i = 1 To Len(ThisFolder)
        FolderPath = FolderPath & Mid(ThisFolder, i, 1)
        If Mid(ThisFolder, i, 1) = "\" Or i = Len(ThisFolder) Then
            If Not objFSO.FolderExists(FolderPath) Then
                Set objFldr = objFSO.CreateFolder(FolderPath)
            End If
        End If
    Next
End Sub
Sub ProcessSubFolder(ThisFolder)
    Dim SubFolder
    For Each SubFolder In ThisFolder.SubFolders
        Set objFolder = objFSO.GetFolder(SubFolder.Path)
        For Each objFile In objFolder.Files
            ProcessFile objFile.Path
        Next
        ProcessSubFolder SubFolder
    Next
End Sub
 
Upvote 0
Looks good will let you know when I get the chance to have a play around with it.

Tested what you said and the error is gone now
 
Upvote 0

Forum statistics

Threads
1,213,558
Messages
6,114,297
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top