VBA - Search all workbooks in a folder for text criteria but only specified sheet

[hippyrider]

Hi experts

I have been trying to modify the below to search all workbooks in a specific folder but restrict the search to the IndexPage sheet not all the sheets. Any ideas my "If wks.Name = "IndexPage" Then" does not speed it up at all.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then

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

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    'Change as desired
    strPath = "D:\shops\Stats"
    strSearch = Range("A1").Value
 
    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Link"
        .Cells(lRow, 2) = "Workbook"
        .Cells(lRow, 3) = "Worksheet"
        .Cells(lRow, 4) = "Cell"
        .Cells(lRow, 5) = "Text in Cell"
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)

        strFile = Dir(strPath & "\*.xlsm*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open _
              (Filename:=strPath & "\" & strFile, _
              UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)

        For Each wks In wbk.Worksheets
            If wks.Name = "IndexPage" Then
                Set rFound = wks.UsedRange.Find(strSearch)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                        .Cells(lRow, 1) = "=HYPERLINK(""[D:\shops\Stats\" & wbk.Name & "]ChartView!A1"",""CLICK HERE"")"
                        .Cells(lRow, 2) = wbk.Name
                        .Cells(lRow, 3) = wks.Name
                        .Cells(lRow, 4) = rFound.Address
                        .Cells(lRow, 5) = rFound.Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            End If
        Next

            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:E").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 If

 

[BobBridges]

...trying to modify the below to search all workbooks in a specific folder but restrict the search to the IndexPage sheet not all the sheets...

So what you have now isn't doing that? What is it doing? Is it not searching all the workbooks in the folder, or is it looking at the wrong worksheet in each, or what?

...my "If wks.Name = "IndexPage" Then" does not speed it up at all.

Wait, now you're saying it works but it's slow?

 

[Marc L]

Hi, use Dir function as explained in VBA help …​

​

 

[rlv01]

If you are opening and closing a lot of files, then it is going to take some finite amount of time to run. You could maybe trim it a little (example, not tested):

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then

        Dim strSearch As String
        Dim strPath As String
        Dim strFile As String
        Dim wOut As Worksheet
        Dim wbk As Workbook
        Dim wks As Worksheet
        Dim lRow As Long
        Dim rFound As Range
        Dim strFirstAddress As String
        Dim ShtCnt As Long
        Dim ST As Single

        ST = Timer                                    'code timer

        On Error GoTo ErrHandler
        Application.ScreenUpdating = False

        'Change as desired
        strPath = "D:\shops\Stats"
        strSearch = Range("A1").Value

        Set wOut = Worksheets.Add
        DoEvents
        lRow = 1

        strFile = Dir(strPath & "\*.xlsm*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open(Filename:=strPath & "\" & strFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            DoEvents
            On Error Resume Next
            Set wks = wbk.Worksheets("IndexPage")
            On Error GoTo ErrHandler

            If Not wks Is Nothing Then
                ShtCnt = ShtCnt + 1
                Set rFound = wks.UsedRange.Find(strSearch)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                        With wOut
                            .Cells(lRow, 1) = "=HYPERLINK(""[D:\shops\Stats\" & wbk.Name & "]ChartView!A1"",""CLICK HERE"")"
                            .Cells(lRow, 2) = wbk.Name
                            .Cells(lRow, 3) = wks.Name
                            .Cells(lRow, 4) = rFound.Address
                            .Cells(lRow, 5) = rFound.Value
                        End With
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            End If
            wbk.Close False
            DoEvents
            strFile = Dir()
            Set wks = Nothing
        Loop

        With wOut
            If ShtCnt > 0 Then
                .Cells(1, 1) = "Link"
                .Cells(1, 2) = "Workbook"
                .Cells(1, 3) = "Worksheet"
                .Cells(1, 4) = "Cell"
                .Cells(1, 5) = "Text in Cell"
                .Columns("A:E").EntireColumn.AutoFit
            Else
                Application.DisplayAlerts = False
                .Delete
                Application.DisplayAlerts = True
            End If
        End With
        MsgBox "Done." & vbCr & "(elapsed time: " & Timer - ST & " sec)"

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

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

Though sometimes when file processing delay is unavoidable, adding a progress bar to manage user expectations is a good choice.

 

[hippyrider]

I have found a good solution. I've taken every file and copied it to a new folder called index, then for every workbook i have striped out all worksheets except the index, now each new workbook i receive i will do the same but its only one a day. so i now search the index dir for a match but the result points to the full fat file. Speeded up greatly and makes it a good solution.