Search Multiple Files in Folder

[Norske77]

Hi,

I have found the following and modified it a bit but need to modify it a little more for my needs. This allows the user to enter the search criteria and folder to be searched. It then goes through all files in that folder and identifies the files that contain the criteria being searched. I would like to only search in a specified worksheet ("EM") in each workbook. In addition I need to add to the output. Currently this is creating a new tab with four data items. I would also like to return another specified cell from the same row in which the specified data was found. This cell will always be 6 columns to the right of the Found.Address.

Thanks in advance for the help!

Sub SearchFolders()
    Dim Fso As Object
    Dim Fld As Object
    Dim RngSearch As Range
    Dim StrPath As String
    Dim StrFile As String
    Dim Out As Worksheet
    Dim Wb As Workbook
    Dim Wk As Worksheet
    Dim Row As Long
    Dim Found As Range
    Dim StrAddress As String
    Dim FileDialog As FileDialog
    Dim Update As Boolean
    Dim Count As Long
    On Error GoTo ErrHandler
    Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    FileDialog.AllowMultiSelect = False
    FileDialog.Title = "Select a forlder"
    If FileDialog.Show = -1 Then
        StrPath = FileDialog.SelectedItems(1)
    End If
    If StrPath = "" Then Exit Sub
    Set RngSearch = ActiveWorkbook.Worksheets("Sheet1").Range("B3:E5")
    Update = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set Out = Worksheets.Add
    Row = 1
    With Out
        .Cells(Row, 1) = "Workbook"
        .Cells(Row, 2) = "Worksheet"
        .Cells(Row, 3) = "Cell Address"
        .Cells(Row, 4) = "Search Criteria"
        .Cells(Row, 5) = "QLE Date"
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Fld = Fso.GetFolder(StrPath)
        StrFile = Dir(StrPath & "\*.xls*")
        Do While StrFile <> ""
            Set Wb = Workbooks.Open(Filename:=StrPath & "" & StrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            For Each Wk In Wb.Worksheets
                Set Found = Wk.UsedRange.Find(RngSearch)
                If Not Found Is Nothing Then
                    StrAddress = Found.Address
                End If
                Do
                    If Found Is Nothing Then
                        Exit Do
                    Else
                        Count = Count + 1
                        Row = Row + 1
                        .Cells(Row, 1) = Wb.Name
                        .Cells(Row, 2) = Wk.Name
                        .Cells(Row, 3) = Found.Address
                        .Cells(Row, 4) = Found.Value
                        .Cells(Row, 5) = ????
                    End If
                    Set Found = Wk.Cells.FindNext(After:=Found)
                Loop While StrAddress <> Found.Address
            Next
            Wb.Close (False)
            StrFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit
    End With
    MsgBox Count & "cells have been found"
ExitHandler:
    Set Out = Nothing
    Set Wk = Nothing
    Set Wb = Nothing
    Set Fld = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = Update
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

 

[Macropod]

After:
For Each Wk In Wb.Worksheets
Insert:
If Wk.Name = "EM" Then
and after:
Loop While StrAddress <> Found.Address
insert:
Exit For
End If

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.

 

[Norske77]

Thanks! That worked perfect for the worksheet question. Any ideas on my second question about pulling additional data from each each worksheet? I need to add to the output. Currently this code is creating a new tab with four data items. I would also like to return another specified cell from the same row in which the Found.Value was found. The cell I want to pull will always be 6 columns to the right of the Found.Address.

Sub SearchFolders()    Dim Fso As Object
    Dim Fld As Object
    Dim RngSearch As Range
    Dim StrPath As String
    Dim StrFile As String
    Dim Out As Worksheet
    Dim Wb As Workbook
    Dim Wk As Worksheet
    Dim Row As Long
    Dim Found As Range
    Dim StrAddress As String
    Dim FileDialog As FileDialog
    Dim Update As Boolean
    Dim Count As Long
    On Error GoTo ErrHandler
    Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    FileDialog.AllowMultiSelect = False
    FileDialog.Title = "Select a forlder"
    If FileDialog.Show = -1 Then
        StrPath = FileDialog.SelectedItems(1)
    End If
    If StrPath = "" Then Exit Sub
    Set RngSearch = ActiveWorkbook.Worksheets("Sheet1").Range("B3:E5")
    Update = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set Out = Worksheets.Add
    Row = 1
    With Out
        .Cells(Row, 1) = "Workbook"
        .Cells(Row, 2) = "Worksheet"
        .Cells(Row, 3) = "Cell"
        .Cells(Row, 4) = "Text in Cell"
        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Fld = Fso.GetFolder(StrPath)
        StrFile = Dir(StrPath & "\*.xls*")
        Do While StrFile <> ""
            Set Wb = Workbooks.Open(Filename:=StrPath & "\" & StrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            For Each Wk In Wb.Worksheets
                If Wk.Name = "EM" Then
                Set Found = Wk.UsedRange.Find(RngSearch)
                If Not Found Is Nothing Then
                    StrAddress = Found.Address
                End If
                Do
                    If Found Is Nothing Then
                        Exit Do
                    Else
                        Count = Count + 1
                        Row = Row + 1
                        .Cells(Row, 1) = Wb.Name
                        .Cells(Row, 2) = Wk.Name
                        .Cells(Row, 3) = Found.Address
                        .Cells(Row, 4) = Found.Value
                    End If
                    Set Found = Wk.Cells.FindNext(After:=Found)
                Loop While StrAddress <> Found.Address
                Exit For
                End If
            Next
            Wb.Close (False)
            StrFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit
    End With
    MsgBox Count & "cells have been found"
ExitHandler:
    Set Out = Nothing
    Set Wk = Nothing
    Set Wb = Nothing
    Set Fld = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = Update
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

 

[Macropod]

Try:
.Cells(Row, 5) = Found.Offset(0, 6).Value

 

[Norske77]

That did it thanks. I am now trying to modify the range that is being searched as the live files have two columns that contain the exact data I am searching.

I changed the following:

[COLOR=#333333]Set Found = Wk.UsedRange.Find(RngSearch)[/COLOR]

to

  Set Found = Range("B:B").Find(RngSearch)

but it is not giving me the expected result of just searching column "B". Any ideas on how to fix this?

Thanks for all of your help!

 

[Norske77]

I think I have identified the problem. I modified the following line in addition to the one above and it appears to be working now.

[COLOR=#333333]Loop While StrAddress <> Found.Address[/COLOR]

to

[COLOR=#333333]Loop While StrAddress = Found.Address[/COLOR]

 

[Norske77]

That did not fix it. Made it worse in fact.

 

[Macropod]

Set Found = Wk.Range("B:B").Find(RngSearch)
or:
Set Found = Wk.Range("B1:B" & Wk.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row).Find(RngSearch)