Find folder with next to latest date

E

Ed

I have a macro which uses Dir$ to search through a series of folders with
dates in the name for the one with the latest date. I do this to find a
file and update it with new information. Unfortunately, my own cleverness
has done me in! The macro in question is run after another macro has
created a bunch of new files and stored them in a new folder - with today's
date, of course. And without my file to update, of course! So the macro
throws up its hands and quits because it can't find a file that's not there.

What I need is a way to find the *next to* latest date. I _usually_ run
this on the same day every week, but I can't guarantee this, so I can't for
sure say the dates are a week apart. Any ideas?

Ed
 
B

Bernie Deitrick

Ed,

Below is a cobbled together code, which will work but which is certainly not
optimized, that will show the 2nd newest subfolder in a directory.

Change the path and folder name in the sub "test" and give it a try. You can
pass the folder name to your routine rather than using the msgbox.

HTH,
Bernie
MS Excel MVP

Sub test()
FindSecondNewestFolder "C:\Excel"
End Sub


Sub FindSecondNewestFolder(myPath As String)
Dim rw As Long
Dim ilevel As Long
Dim sPath As String
Dim Drive As String
Dim AnyName As String
Dim Volume As String
Dim i As Integer
Dim tot As Long
Dim sName1 As String
Dim FolderInfo() As String

Drive = myPath
If Trim(Drive) = "" Then Exit Sub
If Right(Drive, 1) <> "\" Then
Drive = Drive & "\"
End If
Dim sArr() As String
ReDim sArr(1 To 1)
rw = 1
ilevel = 1
AnyName = Dir(Drive, vbDirectory)
If AnyName = "" Then
MsgBox "That folder doesn't exist"
Exit Sub
End If
Do While AnyName <> ""
If AnyName <> "." And AnyName <> ".." _
And GetAttr(Drive & AnyName) = vbDirectory Then
sArr(UBound(sArr)) = AnyName
ReDim Preserve sArr(1 To UBound(sArr) + 1)
End If
AnyName = Dir()
Loop
ilevel = ilevel + 1
For i = 1 To UBound(sArr) - 1
AnyName = sArr(i)
sPath = Drive & AnyName & "\"
ReDim Preserve FolderInfo(1 To 2, 1 To rw)
FolderInfo(1, rw) = Drive & AnyName
FolderInfo(2, rw) = FileDateTime(Drive & AnyName)
rw = rw + 1
sName1 = Dir(sPath, vbNormal)
tot = 0
Do While sName1 <> ""
tot = tot + FileLen(sPath & sName1)
sName1 = Dir()
Loop
sPath = Drive & AnyName & "\"
GetSubs sPath, rw, ilevel + 1
Next

Dim myTemp1 As String
Dim myTemp2 As String
Dim j As Integer

'Do the sort
For i = LBound(FolderInfo, 2) To UBound(FolderInfo, 2) - 1
For j = i + 1 To UBound(FolderInfo, 2)
If FolderInfo(2, i) > FolderInfo(2, j) Then
myTemp1 = FolderInfo(1, j)
myTemp2 = FolderInfo(2, j)
FolderInfo(1, j) = FolderInfo(1, i)
FolderInfo(2, j) = FolderInfo(2, i)
FolderInfo(1, i) = myTemp1
FolderInfo(2, i) = myTemp2
End If
Next j
Next i


MsgBox "The second newest folder is " & FolderInfo(1, rw - 1) & _
Chr(10) & "Created " & FolderInfo(2, rw - 1)


End Sub


Sub GetSubs(sPath As String, _
rw As Long, ilevel As Long)
Dim sName As String
Dim sName1 As String
Dim i As Long
Dim sArr()
Dim sPath1 As String
Dim tot As Long
Dim rw1 As Long
ReDim sArr(1 To 1)
sName = Dir(sPath, vbDirectory)
Do While sName <> ""
If sName <> "." And sName <> ".." Then
If GetAttr(sPath & sName) = vbDirectory Then
sArr(UBound(sArr)) = sName
ReDim Preserve sArr(1 To UBound(sArr) + 1)
End If
End If
sName = Dir()
Loop
For i = 1 To UBound(sArr) - 1
sName = sArr(i)
rw1 = rw
sPath1 = sPath & sName & "\"
sName1 = Dir(sPath1, vbNormal)
tot = 0
Do While sName1 <> ""
tot = tot + FileLen(sPath1 & sName1)
sName1 = Dir()
Loop
GetSubs sPath & sName & "\", rw, ilevel + 1
Next i

End Sub
 
E

Ed

Thanks, Bernie. I'll give it a shot.

Ed

Bernie Deitrick said:
Ed,

Below is a cobbled together code, which will work but which is certainly not
optimized, that will show the 2nd newest subfolder in a directory.

Change the path and folder name in the sub "test" and give it a try. You can
pass the folder name to your routine rather than using the msgbox.

HTH,
Bernie
MS Excel MVP

Sub test()
FindSecondNewestFolder "C:\Excel"
End Sub


Sub FindSecondNewestFolder(myPath As String)
Dim rw As Long
Dim ilevel As Long
Dim sPath As String
Dim Drive As String
Dim AnyName As String
Dim Volume As String
Dim i As Integer
Dim tot As Long
Dim sName1 As String
Dim FolderInfo() As String

Drive = myPath
If Trim(Drive) = "" Then Exit Sub
If Right(Drive, 1) <> "\" Then
Drive = Drive & "\"
End If
Dim sArr() As String
ReDim sArr(1 To 1)
rw = 1
ilevel = 1
AnyName = Dir(Drive, vbDirectory)
If AnyName = "" Then
MsgBox "That folder doesn't exist"
Exit Sub
End If
Do While AnyName <> ""
If AnyName <> "." And AnyName <> ".." _
And GetAttr(Drive & AnyName) = vbDirectory Then
sArr(UBound(sArr)) = AnyName
ReDim Preserve sArr(1 To UBound(sArr) + 1)
End If
AnyName = Dir()
Loop
ilevel = ilevel + 1
For i = 1 To UBound(sArr) - 1
AnyName = sArr(i)
sPath = Drive & AnyName & "\"
ReDim Preserve FolderInfo(1 To 2, 1 To rw)
FolderInfo(1, rw) = Drive & AnyName
FolderInfo(2, rw) = FileDateTime(Drive & AnyName)
rw = rw + 1
sName1 = Dir(sPath, vbNormal)
tot = 0
Do While sName1 <> ""
tot = tot + FileLen(sPath & sName1)
sName1 = Dir()
Loop
sPath = Drive & AnyName & "\"
GetSubs sPath, rw, ilevel + 1
Next

Dim myTemp1 As String
Dim myTemp2 As String
Dim j As Integer

'Do the sort
For i = LBound(FolderInfo, 2) To UBound(FolderInfo, 2) - 1
For j = i + 1 To UBound(FolderInfo, 2)
If FolderInfo(2, i) > FolderInfo(2, j) Then
myTemp1 = FolderInfo(1, j)
myTemp2 = FolderInfo(2, j)
FolderInfo(1, j) = FolderInfo(1, i)
FolderInfo(2, j) = FolderInfo(2, i)
FolderInfo(1, i) = myTemp1
FolderInfo(2, i) = myTemp2
End If
Next j
Next i


MsgBox "The second newest folder is " & FolderInfo(1, rw - 1) & _
Chr(10) & "Created " & FolderInfo(2, rw - 1)


End Sub


Sub GetSubs(sPath As String, _
rw As Long, ilevel As Long)
Dim sName As String
Dim sName1 As String
Dim i As Long
Dim sArr()
Dim sPath1 As String
Dim tot As Long
Dim rw1 As Long
ReDim sArr(1 To 1)
sName = Dir(sPath, vbDirectory)
Do While sName <> ""
If sName <> "." And sName <> ".." Then
If GetAttr(sPath & sName) = vbDirectory Then
sArr(UBound(sArr)) = sName
ReDim Preserve sArr(1 To UBound(sArr) + 1)
End If
End If
sName = Dir()
Loop
For i = 1 To UBound(sArr) - 1
sName = sArr(i)
rw1 = rw
sPath1 = sPath & sName & "\"
sName1 = Dir(sPath1, vbNormal)
tot = 0
Do While sName1 <> ""
tot = tot + FileLen(sPath1 & sName1)
sName1 = Dir()
Loop
GetSubs sPath & sName & "\", rw, ilevel + 1
Next i

End Sub
Click to expand...
 
Top