| Home |
| Search |
| Today's Posts |
|
|
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
FileSearch to locate the latest (last saved) file
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").Va lue Worksheets("Dashboard").Range("B" & z).Value = Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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 a 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? -- PK "Joel" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = Worksheets(ActiveSheet.Name).Range("CompPct").Valu e sReport.Close SaveChanges = False Worksheets(ActiveSheet.Name).Select Worksheets(ActiveSheet.Name).Visible = False Sheets("Dashboard").Select |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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 a 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? -- PK "Joel" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK "Joel" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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 a 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? -- PK "Joel" wrote: 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) |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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 "Patrick Kirk" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK "Joel" wrote: 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 |
|
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK "Joel" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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 a 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? -- PK "Joel" wrote: 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) |
|
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK "Joel" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 "Patrick Kirk" wrote: 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 a 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? -- PK "Joel" wrote: 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) |
|
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
FileSearch to locate the latest (last saved) file
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 "Patrick Kirk" wrote: 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").Va lue Worksheets("Dashboard").Range("B" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgName").V alue Worksheets("Dashboard").Range("C" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staPrgMgr").Va lue Worksheets("Dashboard").Range("D" & z).Value = _ Worksheets(ActiveSheet.Name).Range("staDelDate").V alue Worksheets("Dashboard").Range("F" & z).Value = _ Worksheets(ActiveSheet.Name).Range("TotVariance"). Value Worksheets("Dashboard").Range("G" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e Worksheets("Dashboard").Range("Q" & z).Value = _ Worksheets(ActiveSheet.Name).Range("CompPct").Valu e 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 -- PK "Joel" wrote: 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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Latest Taxation Books available at jain book depot LATEST BOOKRELEASES | Excel Worksheet Functions | |||
| Filesearch finding the same file twice? | Excel Programming | |||
| Using .filesearch for text within a file | Excel Programming | |||
| FileSearch fails to locate *.jpg and *.tif files | Excel Programming | |||
| FileSearch & .zip file | Excel Programming | |||
Hybrid Mode
