FileSearch to locate the latest (last saved) file

P

Patrick Kirk

I am attempting to utilize the .FileSearch operation to search for certain
file(s) within a pre-defined directory and all subdirectories. The below
scripts will copy all worksheets of the workbook found to a main workbook and
list the findings in a worksheet. The problem is if there are two files
beginning with the search cretiria, (ex: R00291 or R00294) it will display
all files.

How do I change the code to find only the latest (last created) file?

Output Once script is ran!+++++++++++++++++++++++++++++++++++
R00263 Asdf George Jeffer 1-Jan-01 0 43%
R00276 Sdfasdf George Jeffer 1-Jan-01 0 77%
R00291 Sdafas William Clinton 1-Jan-01 0 40%
R00294 S Nick Bush 1-Jan-01 0 64%
R00287 D Nick Bush 1-Jan-01 0 91%
R00294 S Nick Bush 1-Jan-01 0 64%
R00291 Sdafas William Clinton 1-Jan-01 0 40%
R00291 Sdafas William Clinton 1-Jan-01 450 40%
R00291 Sdafas William Clinton 1-Jan-01 450 40%

++++++++++++++++++++++++++++++++++



Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, pname
As String, NumFound As String

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = dirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending,
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
For i = 1 To NewestFile
NewestFile = .FoundFiles(1)
'Fil = .FoundFiles(i)
Fil = NewestFile
'Get file path from file name
FPath = Left(Fil, Len(Fil) - Len(Split(Fil,
"\")(UBound(Split(Fil, "\")))) - 1)

If Left$(Fil, 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(Fil))) Then
x = (Array(Dir(Fil))(0))
End If
Set sReport = Workbooks.Open(.FoundFiles(i),
UpdateLinks:=0)

DelFormula

sReport.Worksheets(1).Copy
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If i = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value =
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value =
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value =
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value =
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value =
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value =
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value =
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="",
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub

+++++++++++++++++++++++++++++

Sub Wks_delete()
Dim i As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = ActiveWorkbook.Worksheets.Count To 1 Step -1
If Worksheets(i).Name <> "Dashboard" Then _
Worksheets(i).Delete
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
++++++++++++++++++++++
Sub ClearContents()
Dim rng As Range
Set rng = Range("A7:D70")
rng.ClearContents
Set rng = Range("F7:Q70")
rng.ClearContents
End Sub
 
J

Joel

I added some code that may help. Because each file is in a different
directory you must take all the file informationm and perform a sort. I
created an array to put all this inrformation so you can perform a sort.
After the sort I added a section which determines the latest file by marking
the file true

Note: getfilename extracts just the filename from the path.

Let me know if you have any questions. the code is a little complicated.


Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, _
pname As String, NumFound As String
Dim FileDates As Variant

Set fs = CreateObject("Scripting.FileSystemObject")

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = dirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending, _
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
ReDim FileDates(NewestFile, 4)
'get array to sort
For i = 1 To NewestFiles
Myfile = fs.GetFile(.FoundFiles(i))
FileDates(i, 1) = Myfile.Date
FileDates(i, 2) = Myfile.getfilename(Myfile.Name)
FileDates(i, 3) = i 'keep index number to use after sort
FileDates(i, 4) = False 'boolean indicating if latest
Next i
'sort by date newest to oldest
For i = 1 To (NewestFiles - 1)
For j = (i + 1) To NewestFiles
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'sort by filename
For i = 1 To (NewestFiles - 1)
For j = (i + 1) To NewestFiles
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'determine latest file
'first entry is always the latest
FileDates(1, 4) = True
For i = 2 To NewestFiles
If FileDates(i, 2) <> FileDates(i - 1, 2) Then
FileDates(i, 4) = True
End If
Next
'the latest files are the ones with True in index 4
'index 3 is the index number in foundfiles

For i = 1 To NewestFile
NewestFile = .FoundFiles(1)
'Fil = .FoundFiles(i)
Fil = NewestFile
'Get file path from file name
FPath = Left(Fil, Len(Fil) - Len(Split(Fil, _
"\")(UBound(Split(Fil, "\")))) - 1)

If Left$(Fil, 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(Fil))) Then
x = (Array(Dir(Fil))(0))
End If
Set sReport = Workbooks.Open(.FoundFiles(i), _
UpdateLinks:=0)

' DelFormula

sReport.Worksheets(1).Copy _
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If i = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value = _
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="", _
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub

'+++++++++++++++++++++++++++++

Sub Wks_delete()
Dim i As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = ActiveWorkbook.Worksheets.Count To 1 Step -1
If Worksheets(i).Name <> "Dashboard" Then _
Worksheets(i).Delete
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'++++++++++++++++++++++
Sub ClearContents()
Dim rng As Range
Set rng = Range("A7:D70")
rng.ClearContents
Set rng = Range("F7:Q70")
rng.ClearContents
End Sub
 
P

Patrick Kirk

Joel,

No luck, I continue to experience the problem of showing all documents not
just the latest modified/updated.

Example:
R00276 Sdfasdf George Jeffers 1-Jan-01 0 77%
R00287 D Nick Bush 1-Jan-01 0 91%
R00291 Sdafas William Clinton 1-Jan-01 450 40%
R00294 S Nick Bush 1-Jan-01 0 64%
R00307 Ies Tactics Nick Bh 1-Jan-02 500 40%
R00291 Sdafas William Clinton 1-Jan-01 450 40%



My filesearch searches for "Sts*.xls". The document names are:
StsRpt_R00291_26Jan08.xls & StsRpt_R00291_27Jan08.xls; both might be in the
same directory or different directories.

Is there a way to only show the last modified file of each instance found?
 
J

Joel

My original code was not complete. It was just to get you started. I made a
few more changes, see if this helps

Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, _
pname As String, NumFound As String
Dim FileDates As Variant

Set fs = CreateObject("Scripting.FileSystemObject")

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = dirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending, _
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
ReDim FileDates(NewestFile, 4)
'get array to sort
For i = 1 To NewestFiles
Myfile = fs.GetFile(.FoundFiles(i))
FileDates(i, 1) = Myfile.Date
FileDates(i, 2) = Myfile.getfilename(Myfile.Name)
FileDates(i, 3) = i 'keep index number to use after sort
FileDates(i, 4) = False 'boolean indicating if latest
Next i
'sort by date newest to oldest
For i = 1 To (NewestFiles - 1)
For j = (i + 1) To NewestFiles
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'sort by filename
For i = 1 To (NewestFiles - 1)
For j = (i + 1) To NewestFiles
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'determine latest file
'first entry is always the latest
FileDates(1, 4) = True
For i = 2 To NewestFiles
If FileDates(i, 2) <> FileDates(i - 1, 2) Then
FileDates(i, 4) = True
End If
Next
'the latest files are the ones with True in index 4
'index 3 is the index number in foundfiles

For i = 1 To NewestFile
' NewestFile = .FoundFiles(1)
' 'Fil = .FoundFiles(i)
' Fil = NewestFile
'Get file path from file name
' FPath = Left(Fil, Len(Fil) - Len(Split(Fil, _
'"\")(UBound(Split(Fil, "\")))) - 1)

' If Left$(Fil, 1) = Left$(fLdr, 1) Then
' If CBool(Len(Dir(Fil))) Then
' x = (Array(Dir(Fil))(0))
' End If
If FileDates(i, 4) = True Then
Set sReport = Workbooks.Open(.FoundFiles(FileDates(i,
3)), _
UpdateLinks:=0)

' DelFormula

sReport.Worksheets(1).Copy _
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If FileDates(i, 3) = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value = _
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="", _
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub

'+++++++++++++++++++++++++++++

Sub Wks_delete()
Dim i As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = ActiveWorkbook.Worksheets.Count To 1 Step -1
If Worksheets(i).Name <> "Dashboard" Then _
Worksheets(i).Delete
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'++++++++++++++++++++++
Sub ClearContents()
Dim rng As Range
Set rng = Range("A7:D70")
rng.ClearContents
Set rng = Range("F7:Q70")
rng.ClearContents
End Sub
 
P

Patrick Kirk

Joel,

I think Im missing something here. Im still receiving the same output. I've
followed the array as much as I can with my limited knowledge of VBA but
couldn't find where the code actually determines the latest instance of a
file.

If Im not mistaken, it appears if the array object #4 is true, then the
contents of the array is written. I also made a modification to the code
referencing the Getfile and Getfilename methods. What are your thoughts?

Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, _
pname As String, NumFound As String
Dim FileDates As Variant

Set fs = CreateObject("Scripting.FileSystemObject")

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = DirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.FileName = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending, _
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
ReDim FileDates(NewestFile, 4)
'get array to sort
For i = 1 To NewestFile
myfile = fs.getfile(.FoundFiles(i))
Set jj = fs.getfile(.FoundFiles(i))
xxx = fs.Getfilename(.FoundFiles(i))
FileDates(i, 1) = jj.Datecreated
FileDates(i, 2) = xxx 'myfile.Getfilename(myfile.Name)
FileDates(i, 3) = i 'keep index number to use after sort
FileDates(i, 4) = False 'boolean indicating if latest
Next i
'sort by date newest to oldest
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'sort by filename
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'determine latest file
'first entry is always the latest
FileDates(1, 4) = True
For i = 2 To NewestFile
If FileDates(i, 2) <> FileDates(i - 1, 2) Then
FileDates(i, 4) = True
End If
Next
'the latest files are the ones with True in index 4
'index 3 is the index number in foundfiles

For i = 1 To NewestFile
' NewestFile = .FoundFiles(1)
' 'Fil = .FoundFiles(i)
' Fil = NewestFile
'Get file path from file name
' FPath = Left(Fil, Len(Fil) - Len(Split(Fil, _
'"\")(UBound(Split(Fil, "\")))) - 1)

' If Left$(Fil, 1) = Left$(fLdr, 1) Then
' If CBool(Len(Dir(Fil))) Then
' x = (Array(Dir(Fil))(0))
' End If
If FileDates(i, 4) = True Then
Set sReport = Workbooks.Open(.FoundFiles(FileDates(i,
3)), UpdateLinks:=0)

' DelFormula

sReport.Worksheets(1).Copy _
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If FileDates(i, 3) = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value = _
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="", _
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
 
P

Patrick Kirk

Joel,

I think Im missing something here. Im still receiving the same output. I've
followed the array as much as I can with my limited knowledge of VBA but
couldn't find where the code actually determines the latest instance of a
file.

If Im not mistaken, it appears if the array object #4 is true, then the
contents of the array is written. I also made a modification to the code
referencing the Getfile and Getfilename methods. What are your thoughts?

Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, _
pname As String, NumFound As String
Dim FileDates As Variant

Set fs = CreateObject("Scripting.FileSystemObject")

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = DirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.FileName = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending, _
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
ReDim FileDates(NewestFile, 4)
'get array to sort
For i = 1 To NewestFile
myfile = fs.getfile(.FoundFiles(i))
Set jj = fs.getfile(.FoundFiles(i))
xxx = fs.Getfilename(.FoundFiles(i))
FileDates(i, 1) = jj.Datecreated
FileDates(i, 2) = xxx 'myfile.Getfilename(myfile.Name)
FileDates(i, 3) = i 'keep index number to use after sort
FileDates(i, 4) = False 'boolean indicating if latest
Next i
'sort by date newest to oldest
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'sort by filename
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'determine latest file
'first entry is always the latest
FileDates(1, 4) = True
For i = 2 To NewestFile
If FileDates(i, 2) <> FileDates(i - 1, 2) Then
FileDates(i, 4) = True
End If
Next
'the latest files are the ones with True in index 4
'index 3 is the index number in foundfiles

For i = 1 To NewestFile
' NewestFile = .FoundFiles(1)
' 'Fil = .FoundFiles(i)
' Fil = NewestFile
'Get file path from file name
' FPath = Left(Fil, Len(Fil) - Len(Split(Fil, _
'"\")(UBound(Split(Fil, "\")))) - 1)

' If Left$(Fil, 1) = Left$(fLdr, 1) Then
' If CBool(Len(Dir(Fil))) Then
' x = (Array(Dir(Fil))(0))
' End If
If FileDates(i, 4) = True Then
Set sReport = Workbooks.Open(.FoundFiles(FileDates(i,
3)), UpdateLinks:=0)

' DelFormula

sReport.Worksheets(1).Copy _
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If FileDates(i, 3) = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value = _
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="", _
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
 
P

Patrick Kirk

Joel,

I think Im missing something here. Im still receiving the same output. I've
followed the array as much as I can with my limited knowledge of VBA but
couldn't find where the code actually determines the latest instance of a
file.

If Im not mistaken, it appears if the array object #4 is true, then the
contents of the array is written. I also made a modification to the code
referencing the Getfile and Getfilename methods. What are your thoughts?

Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, _
pname As String, NumFound As String
Dim FileDates As Variant

Set fs = CreateObject("Scripting.FileSystemObject")

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = DirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.FileName = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending, _
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
ReDim FileDates(NewestFile, 4)
'get array to sort
For i = 1 To NewestFile
myfile = fs.getfile(.FoundFiles(i))
Set jj = fs.getfile(.FoundFiles(i))
xxx = fs.Getfilename(.FoundFiles(i))
FileDates(i, 1) = jj.Datecreated
FileDates(i, 2) = xxx 'myfile.Getfilename(myfile.Name)
FileDates(i, 3) = i 'keep index number to use after sort
FileDates(i, 4) = False 'boolean indicating if latest
Next i
'sort by date newest to oldest
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'sort by filename
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 1) > FileDates(i, 1) Then
temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

temp = FileDates(i, 4)
FileDates(i, 4) = FileDates(j, 4)
FileDates(j, 4) = temp

End If
Next j
Next i

'determine latest file
'first entry is always the latest
FileDates(1, 4) = True
For i = 2 To NewestFile
If FileDates(i, 2) <> FileDates(i - 1, 2) Then
FileDates(i, 4) = True
End If
Next
'the latest files are the ones with True in index 4
'index 3 is the index number in foundfiles

For i = 1 To NewestFile
' NewestFile = .FoundFiles(1)
' 'Fil = .FoundFiles(i)
' Fil = NewestFile
'Get file path from file name
' FPath = Left(Fil, Len(Fil) - Len(Split(Fil, _
'"\")(UBound(Split(Fil, "\")))) - 1)

' If Left$(Fil, 1) = Left$(fLdr, 1) Then
' If CBool(Len(Dir(Fil))) Then
' x = (Array(Dir(Fil))(0))
' End If
If FileDates(i, 4) = True Then
Set sReport = Workbooks.Open(.FoundFiles(FileDates(i,
3)), UpdateLinks:=0)

' DelFormula

sReport.Worksheets(1).Copy _
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If FileDates(i, 3) = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value = _
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value = _
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value = _
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="", _
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
 
J

Joel

I think you need to remove the prefix from the filename in this statement

xxx = fs.Getfilename(.FoundFiles(i))

If you just need the first number before the blank then make this change

xxx = fs.Getfilename(.FoundFiles(i))
xxx = left(xxx,instr(xxx," ") - 1))

This look for the first blank and gets all the characters before the blank
 
P

Patrick Kirk

Joel,

After closely looking at the code you sent, I was able to finally get it to
work. You definitely pointed me in the right direction. I've pasted the code
below. Thanks for you help.

Sub SrchForFiles()

Dim i As Long, z As Long, Rw As Long
Dim sReport As Workbook, sDashboard As Workbook
Dim ws As Worksheet, pat As Workbook
Dim sRpt As Object, dPt As Object
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String, x As String, _
pname As String, NumFound As String
Dim FileDates As Variant

Set fs = CreateObject("Scripting.FileSystemObject")

Wks_delete ' Delete old worksheets
ClearContents

y = "Sts*.xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
fLdr = dirPath '.SelectedItems(1)
Set sDashboard = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets("Dashboard")
On Error GoTo 1
2:
On Error GoTo 0
NumFound = .Execute(msoSortByLastModified, msoSortOrderAscending,
True)
If NumFound > 0 Then
NewestFile = .FoundFiles.Count 'NewestFile = FilesFound(1)
ReDim FileDates(NewestFile, 3)
'get array to sort
For i = 1 To NewestFile
myfile = fs.getfile(.FoundFiles(i))
Set jj = fs.getfile(.FoundFiles(i))
xxx = Left(fs.Getfilename(.FoundFiles(i)), 14)


FileDates(i, 0) = jj.Name
FileDates(i, 1) = xxx 'myfile.Getfilename(myfile.Name)
FileDates(i, 2) = i 'keep index number to use after sort
FileDates(i, 3) = False 'boolean indicating if latest
Next i



'sort by filename
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 0) > FileDates(i, 0) Then
temp = FileDates(i, 0)
FileDates(i, 0) = FileDates(j, 0)
FileDates(j, 0) = temp

temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

End If
Next j
Next i


'sort by date newest to oldest
For i = 1 To (NewestFile - 1)
For j = (i + 1) To NewestFile
If FileDates(j, 0) > FileDates(i, 0) Then
temp = FileDates(i, 0)
FileDates(i, 0) = FileDates(j, 0)
FileDates(j, 0) = temp

temp = FileDates(i, 1)
FileDates(i, 1) = FileDates(j, 1)
FileDates(j, 1) = temp

temp = FileDates(i, 2)
FileDates(i, 2) = FileDates(j, 2)
FileDates(j, 2) = temp

temp = FileDates(i, 3)
FileDates(i, 3) = FileDates(j, 3)
FileDates(j, 3) = temp

End If
Next j
Next i



'determine latest file
'first entry is always the latest
FileDates(1, 3) = True
For i = 2 To NewestFile
If FileDates(i, 1) <> FileDates(i - 1, 1) Then
FileDates(i, 3) = True
End If
Next
'the latest files are the ones with True in index 4
'index 3 is the index number in foundfiles

For i = 1 To NewestFile
If FileDates(i, 3) = True Then
Set sReport = Workbooks.Open(.FoundFiles(FileDates(i,
2))) ', UpdateLinks:=0)

' DelFormula

sReport.Worksheets(1).Copy
After:=sDashboard.Sheets(sDashboard.Sheets.Count)
ActiveSheet.Name = sReport.Name & "(" & i & ")"

If i = 1 Then
z = 7
Else
z = z + 1
End If
Worksheets("Dashboard").Range("A" & z).Value =
Worksheets(ActiveSheet.Name).Range("staPrgNum").Value
Worksheets("Dashboard").Range("B" & z).Value =
Worksheets(ActiveSheet.Name).Range("staPrgName").Value
Worksheets("Dashboard").Range("C" & z).Value =
Worksheets(ActiveSheet.Name).Range("staPrgMgr").Value
Worksheets("Dashboard").Range("D" & z).Value =
Worksheets(ActiveSheet.Name).Range("staDelDate").Value
Worksheets("Dashboard").Range("F" & z).Value =
Worksheets(ActiveSheet.Name).Range("TotVariance").Value
Worksheets("Dashboard").Range("G" & z).Value =
Worksheets(ActiveSheet.Name).Range("CompPct").Value
Worksheets("Dashboard").Range("Q" & z).Value =
Worksheets(ActiveSheet.Name).Range("CompPct").Value
sReport.Close SaveChanges = False
Worksheets(ActiveSheet.Name).Select
Worksheets(ActiveSheet.Name).Visible = False
Sheets("Dashboard").Select
ws.Hyperlinks.Add Range("a" & z), Address:="",
SubAddress:="Dashboard!A" & z
End If
Next i
End If
End With

ActiveWindow.DisplayHeadings = False
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
 
J

Joel

I have bads news for you. FileSearch isn't available in Excel 2007 (that is
what people have told me). some people claim filesearch also doesn't work
under some conditions (large searches). Here is code that does the
equivalent to FileSearch if you arre interested in looking at this code. It
perform a recusive search of all the subdirectories.


Sub getfiles()


Set fso = CreateObject _
("Scripting.FileSystemObject")
Set folder = _
fso.GetFolder("C:\temp\")

If folder.subfolders.Count > 0 Then
For Each sf In folder.subfolders

Set fso1 = CreateObject _
("Scripting.FileSystemObject")
Set folder1 = _
fso1.GetFolder(sf)
If folder1.Files.Count > 0 Then
For Each file In folder1.Files

'add code to open each file here.
Next file
End If

Next sf
End If

End Sub
Sub getfiles()


Set fso = CreateObject _
("Scripting.FileSystemObject")
Set folder = _
fso.GetFolder("C:\temp\")

If folder.subfolders.Count > 0 Then
For Each sf In folder.subfolders
If InStr(sf, "Agent") Then

Set fso1 = CreateObject _
("Scripting.FileSystemObject")
Set folder1 = _
fso1.GetFolder(sf)
If folder1.Files.Count > 0 Then
For Each file In folder1.Files

'add code to open each file here.
Next file
End If
End If
Next sf
End If

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA for Dependents shortcut menu 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Another 'Copy To The Next Available Row' Question 2
Filesearch in 2007 1
MACRO Effeciency 3
Excel crashes and restarts when accessing newly created worksheet 2
Copy filtered data to sheet 2 1
Can you speed up this code? 2

Top