Organizing Files in Excel using VBA and FileSystemObject - excel

Question

I tried to get this to sort in ascending order from the time and it is not quite working right. It adds all the information, but does not sort the value. Also, I need to add a cut-off so it only uploads the files within the last week (7 days) from the current date. I'm not sure of an effective way to do this.
Thanks!
Option Explicit
Sub ListFiles()
Application.ScreenUpdating = False
Sheets("Sheet2").Select
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "File Name:"
Range("C3").Formula = "Creation Date:"
ListFolders "C:\Users\blake.rupprecht\Desktop\Photos\"
Application.ScreenUpdating = True
End Sub
Sub ListFolders(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim r As Long
Dim sfil As String
Dim par As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error Resume Next
sfil = Dir(SourceFolderName & "\" & "*.jpg*")
Do Until sfil = ""
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveCell.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & sfil, , , sfil
ActiveCell.Offset(, 1).Value = SourceFolder.Files(sfil).DateCreated
ActiveCell.Offset(1).Select
sfil = Dir$
Loop
Columns("A:B").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub

Answer 1

Checking for 7 days tmie span:
If Now - SourceFolder.Files(sfil).DateCreated < 7 Then
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveCell.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & sfil, , , sfil
ActiveCell.Offset(, 1).Value = SourceFolder.Files(sfil).DateCreated
ActiveCell.Offset(1).Select
End If
Please note that the calculation takes time of day into consideration also. If you want just the date, you have to extract integers from operands.
To sort the values, record some sorting and then remodule that code to fit your scenario.

Answer 2

If you want to sort in ascending order, the easiest thing would probably be to add the results to an array, then use a comparison to re-order the array in ascending order, and then write the values to the cells from the array. I'll post an example when I get back to the office.
Code is untested, but should work. Let me know if it doesn't and I'll setup a workbook to test it in. Also, you could break the sorting code out into it's own function, then it's reusable in other routines. Do as you see fit.
I removed the On Error Resume Next statement because it wasn't necessary where you had it. Turning off error notifications is only going to mask errors and make it harder to troubleshoot problems with your code. If you expect errors, write something to handle them, don't just ignore them.
Option Explicit
Sub ListFiles()
Application.ScreenUpdating = False
Sheets("Sheet2").Select
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "File Name:"
Range("C3").Formula = "Creation Date:"
ListFolders "C:\Users\blake.rupprecht\Desktop\Photos\"
Application.ScreenUpdating = True
End Sub
Sub ListFolders(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim r As Long
Dim sfil As String
Dim par As String
Dim lngX As Long
Dim lngY As Long
Dim strX As String
Dim strY As String
Dim strTemp As String
Dim strFiles() As String
ReDim strFiles(0)
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
sfil = Dir(SourceFolderName & "\*.jpg*")
Do Until LenB(sfil) = 0
If Now - SourceFolder.files(sfil).DateCreated < 7 Then
If lngX = 0 And LenB(strFiles(lngX)) = 0 Then
strFiles(0) = sfil
Else
ReDim Preserve strFiles(UBound(strFiles) + 1)
strFiles(UBound(strFiles)) = sfil
End If
End If
Loop
'Sort the array in ascending order
If LenB(srfiles(LBound(strFiles))) > 0 Then
For lngY = 0 To UBound(strFiles) - 1
For lngX = 0 To UBound(strFiles) - 1
'Grab the current and next item in the list to compare
strX = strFiles(lngX)
strY = strFiles(lngX + 1)
'Check if the current item is greater than the next in the list and swap them if it is
If strX > strY Then
strTemp = strFiles(lngX)
strFiles(lngX) = strFiles(lngX + 1)
strFiles(lngX + 1) = strTemp
End If
'Reset the temporary strings so we don't accidentally use the wrong value in case of some unforeseen error
strTemp = vbNullString
strX = vbNullString
strY = vbNullString
Next lngX
Next lngY
End If
For lngX = LBound(strFiles) To UBound(stfiles)
With Range("B" & Rows.Count).End(xlUp).offset(1)
.Hyperlinks.Add ActiveCell, SourceFolderName & "\" & strFiles(lngX), , , strFiles(lngX)
.offset(, 1).Value = SourceFolder.files(strFiles(lngX)).DateCreated
End With
Next
Columns("A:B").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub