Need to add to my search worksheet

[craigwojo]

Hi everyone,
I got a worksheet done a while ago (I can't get in touch with the person that wrote it) and need to revise it.

In the search results, I need to add a search for Word documents also. (*.doc*). Also the columns B,C and D will not be in the result. The result will also be linked back to file so I can click on it and open the word file.

Also, is there a way to have the Word results to the right of the Excel results? (Column F) . The cell (F1) will be a header called "Word Document"
When the results are in TAB "Sheet1" can it be "autofit column width" in the results and Column (E) could be 18 column width?

Thank you all so much. You all do so much for all of us and are very appreciated.

Thank you and God bless,
Craig

I don't know how to upload the module or the Excel file.
Here is the text within the module:


Public FSO As Object
Public fld As Object
Public strSearch As String
Public strPath As String
Public strFile As String
Public wOut As Worksheet
Public wbk As Workbook
Public wks As Worksheet
Public lRow As Long
Public rFound As Range
Public strFirstAddress As String

Sub SearchFolders()

On Error GoTo ErrHandler
Application.ScreenUpdating = False

'Change as desired
strPath = Range("PathFolder").Value
strSearch = Range("cellSearch").Value

If Dir(strPath, vbDirectory) = "" Then
MsgBox "Folder not found please select a folder path!", vbCritical

GoTo ExitHandler
End If
If Len(strSearch) = 0 Then
MsgBox "Please enter Search String in to the respective cell!", vbCritical
GoTo ExitHandler
End If
Set wOut = Worksheets.Add(After:=Sheets(Worksheets.Count))
lRow = 1
With wOut
.Cells(lRow, 1) = "Workbook"
.Cells(lRow, 2) = "Worksheet"
.Cells(lRow, 3) = "Cell"
.Cells(lRow, 4) = "Text in Cell"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(strPath)
searchInFolder fld

.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"

ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set FSO = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

Sub searchInFolder(ByVal fld As Object) '(ByVal folder As Object, ByVal strSearch As String, ByVal wOut As Worksheet, ByRef lRow As Long)
Dim subFolder As Object
With wOut
strFile = Dir(fld.Path & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(fileName:=fld.Path & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch, , xlValues, xlWhole, xlByRows, xlNext, True, False)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Range("A" & lRow).Hyperlinks.Add .Cells(lRow, 1), wbk.Path & "\" & wbk.Name, wks.Name & "!" & rFound.Address, , wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value 'strSearch
End If
Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
wbk.Close (False)
strFile = Dir
Loop
End With
For Each subFolder In fld.SubFolders
searchInFolder subFolder
Next subFolder
End Sub

Public Sub selectFolder()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select a folder"
.AllowMultiSelect = False

If .Show = -1 Then
Range("PathFolder").Value = .SelectedItems(1)
Else
MsgBox "Operation canceled by user.", vbExclamation
Range("PathFolder").Value = ""
Exit Sub
End If
End With
End Sub

 

[craigwojo]

Bump?