PDA

View Full Version : Search Directory and Sub Folders Help



mlutkewi
12-01-2008, 07:52 AM
I have been using some code I found on this website, but have run into a bit of trouble. First I search through an excel sheet looking for text entered by the user. This part works fine. Then I shift over a few cells to find a corresponding reference number, which is also the name of the file I want to search for. For some reason, this search code will not return an exact match of the reference number being searched. Sometimes it returns similar filenames. Does anyone know how I can adjust my code to return the exact file I want? Here is the code, the blue text works fine and the red text is where I believe my issue is.


Private Sub Searchbutton_Click()
MacroFile = ActiveWorkbook.Name
' Searches the selected folders and sub folders for files with the 'specified extension.
'A new worksheet is produced called "File Search Results". You can 'click on the link and go directly
'to the file you need.
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String
Dim FileNameII As String, PathNameII As String

'Set the file path
fLdr = "L:\...confidential..." & Project & "\"
'worksheet "FileSearch Results" contains links to found files
Set ws1 = ThisWorkbook.Worksheets.Add(Sheets(1))
ws1.Name = "FileSearch Results"

With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
'On Error GoTo 1
'temporary sheet to contain initial results
ws.Name = "Log Search Results"
'This will search thru a project's log by the subject and
'selects the corresponding IFM number to search filenames with
If Subname = "" Then
PathNameII = "L:\...confidential..." & Project & "\"
FileNameII = Project & " & RRC incoming-outgoing IFM Log"
Else
PathNameII = "L:\...confidential..." & Project & "\" & Subname & "\"
FileNameII = Project & "(" & Subname & ")" & " & RRC incoming-outgoing IFM Log"
End If
PathFileNameI = PathNameII & FileNameII

'check to see if file is already open by someone
If IsFileOpen(PathFileNameI) = True Then
Workbooks.Open FileName:=PathFileNameI
LogFile = ActiveWorkbook.Name
Else
MsgBox ("The File is Already Open or the Sub Project was not Chosen")
Sheets("Log Search Results").Delete
Sheets("FileSearch Results").Delete
Exit Sub
End If
tinout = RecordIFM.Types.Value
'Searches by Incoming or Outgoing
If tinout = "Incoming" Then
Sheets("Incoming").Select
ElseIf tinout = "Outgoing" Then
Sheets("Outgoing").Select
ElseIf tinout = "" Then
MsgBox ("Please Specify Incoming or Outgoing IFM")
Unload RecordIFM
ActiveWorkbook.Close Savechanges:=False
Windows(MacroFile).Activate
Sheets("Log Search Results").Delete
Sheets("FileSearch Results").Delete
Exit Sub
End If

'Searching for a PARTIAL subject match
Dim subtext As String
subtext = Subject

'Copy all the rows that match the subject
On Error GoTo skiptoend
If IsNothing(Find_Range(subtext, Range("E1:E2000"))) Then
ActiveWorkbook.Close Savechanges:=False
Windows(MacroFile).Activate
Sheets("CreateNewIFM").Select
MsgBox (" No Matches for '" & subtext & "'" & vbCr & _
"Please Choose From the Folder Manually")
ActiveWorkbook.FollowHyperlink Address:=PathNameII, NewWindow:=True
Unload RecordIFM
Exit Sub
End If

'This Section works great
Find_Range(subtext, Range("E1:E2000")).EntireRow.Copy
Windows(MacroFile).Activate
Sheets("Log Search Results").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With ws
With .[A1:I1]
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
End With
Cells(1, 1).Select




'The following Section does not work right.
'Loops thru matching IFM numbers and sets the .Filename
Dim c As Integer
c = 0
Do Until c = ActiveSheet.UsedRange.Rows.Count
.FileName = ActiveCell.Offset(c, 0).Value
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fil = .FoundFiles(i)
'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
z = z + 1
ws1.Cells(z + 1, 1).Resize(, 4) = _
Array(Dir(Fil), FileLen(Fil) / 1000, FileDateTime(Fil), FPath)
ws1.Hyperlinks.Add Anchor:=ws1.Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
c = c + 1
Loop
End With
End If

Sheets("FileSearch Results").Select
ActiveWindow.DisplayHeadings = False
Dim Rw2 As Integer
With ws1
Rw = .Cells.Rows.Count
With .[A1:D1]
.Value = [{"File Name","Size (KB)","Last Modified", "Path"}]
.Font.Underline = xlUnderlineStyleSingle
.Font.Bold = True
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[E1:IV1 ].EntireColumn.Hidden = True
On Error Resume Next
Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
End With

Workbooks(LogFile).Close Savechanges:=False
Application.CutCopyMode = False
Range("A2").Select
Application.ScreenUpdating = True
Dim Msg As String
Msg = " Search is Complete!" & vbCr & vbCr & _
"Click on the IFM Number to Open the File"
MsgBox (Msg)
Unload RecordIFM
Exit Sub

skiptoend:
Application.DisplayAlerts = False
Application.DisplayAlerts = True
MsgBox ("Try Searching With Different or Less Words")
10:
Unload RecordIFM

End Sub

Tommy
12-01-2008, 08:12 AM
Moved to Excel Forum :)

Also added VBA tags

Welcome to the Forum!