Search a particular sheet in multiple workbooks

Paulo H

Board Regular
Joined
Jun 10, 2020
Messages
106
Office Version
  1. 2016
Platform
  1. Windows
Hi

I am trying to search multiple work books to find data and summarise on on sheet. IE I have created a quotation workbook which has the main sheet called quote form. What I want to do is to run a macro that will search all my quotes and pick out certain data IE in example below CR-2AF. I found the attached example which sort of does it but it searches all the sheets in all the quotes I just want it to search the Sheet called Quote form. Any help appreciated please. I also would like to create input box too so as not to have to put item (CR-2AF in VBA code)
VBA Code:
Public Sub searchText()
    Dim FSO As Object
    Dim folder As Object, subfolder As Object
    Dim wb As Object
    Dim ws As Worksheet

    searchList = Array("CR2-AF")   'define the list of text you want to search, case insensitive
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    folderPath = "C:\Users\paulh\OneDrive -  xxxxLimited\Quote 2020" 'define the path of the folder that contains the workbooks
    Set folder = FSO.GetFolder(folderPath)
    Dim thisWbWs, newWS As Worksheet
   
    'Create summary worksheet if not exist
    For Each thisWbWs In ActiveWorkbook.Worksheets
        If wsExists("summary") Then
            counter = 1
        End If
    Next thisWbWs
   
    If counter = 0 Then
        Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        With newWS
            .Name = "summary1"
            .Range("A1").Value = "Target Keyword"
            .Range("B1").Value = "Workbook"
            .Range("C1").Value = "Worksheet"
            .Range("D1").Value = "Address"
            .Range("E1").Value = "Cell Value"
        End With
    End If

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
       
    'Check each workbook in main folder
    For Each wb In folder.Files
        If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
            Set masterWB = Workbooks.Open(wb)
            For Each ws In masterWB.Worksheets
              For Each Rng In ws.UsedRange
                For Each i In searchList
                    If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then   'vbTextCompare means case insensitive.
                        nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                        With ThisWorkbook.Sheets("summary")
                            .Range("A" & nextRow).Value = i
                            .Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
                            .Range("C" & nextRow).Value = ws.Name
                            .Range("D" & nextRow).Value = Rng.Address
                            .Range("E" & nextRow).Value = Rng.Value
                        End With
                    End If
                Next i
              Next Rng
            Next ws
            ActiveWorkbook.Close True
        End If
    Next
   
    'Check each workbook in sub folders
    For Each subfolder In folder.SubFolders
        For Each wb In subfolder.Files
            If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
                Set masterWB = Workbooks.Open(wb)
                For Each ws In masterWB.Worksheets
                  For Each Rng In ws.UsedRange
                    For Each i In searchList
                        If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then
                            nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                            With ThisWorkbook.Sheets("summary")
                                .Range("A" & nextRow).Value = i
                                .Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
                                .Range("C" & nextRow).Value = ws.Name
                                .Range("D" & nextRow).Value = Rng.Address
                                .Range("E" & nextRow).Value = Rng.Value
                            End With
                        End If
                    Next i
                  Next Rng
                Next ws
                ActiveWorkbook.Close True
            End If
        Next
    Next
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
   
    ThisWorkbook.Sheets("summary").Cells.Select
    ThisWorkbook.Sheets("summary").Cells.EntireColumn.AutoFit
    ThisWorkbook.Sheets("summary").Range("A1").Select
   
   
End Sub

Function wsExists(wksName As String) As Boolean
    On Error Resume Next
    wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
    On Error GoTo 0
End Function
Thank you
Paul
 
Last edited by a moderator:

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Hi Paulo
This shoul help
Add in the lines:
If ws.Name <> "Quote form" then GoTo Skip
Skip:
as is below
Put it in both master and sub folder sections

Code:
            For Each ws In masterWB.Worksheets
              If ws.Name <> "Quote form" then GoTo Skip
              For Each Rng In ws.UsedRange
                For Each i In searchList
                    If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then   'vbTextCompare means case insensitive.
                        nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                        With ThisWorkbook.Sheets("summary")
                            .Range("A" & nextRow).Value = i
                            .Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
                            .Range("C" & nextRow).Value = ws.Name
                            .Range("D" & nextRow).Value = Rng.Address
                            .Range("E" & nextRow).Value = Rng.Value
                        End With
                    End If
                Next i
              Next Rng
Skip:
            Next ws
[code]
 
Upvote 0
Is your search criteria, in this case "CR-2AF", anywhere on the sheet "quote form" or is it always in the same column? If in the same column, what is the column letter? Also, is the sheet named "summary" or "summary1"?
 
Upvote 0
Is your search criteria, in this case "CR-2AF", anywhere on the sheet "quote form" or is it always in the same column? If in the same column, what is the column letter? Also, is the sheet named "summary" or "summary1"?
Hi it is always in column D of shet"Quote Form". And yes this is just an example CR-2AF so an input box would be good as another time the search maybe UN-21 etc

Thanks
 
Upvote 0
Is your search criteria, in this case "CR-2AF", anywhere on the sheet "quote form" or is it always in the same column? If in the same column, what is the column letter? Also, is the sheet named "summary" or "summary1"?
Sorry summary
 
Upvote 0
Give this a try:
VBA Code:
Public Sub searchText()
    Dim FSO As Object, folder As Object, subfolder As Object, newWS As Worksheet, wb As Object, response As String
    response = InputBox("Please enter the search string.")
    If response = "" Then Exit Sub
    Set FSO = CreateObject("Scripting.FileSystemObject")
    folderPath = "C:\Users\paulh\OneDrive -  xxxxLimited\Quote 2020\"
    Set folder = FSO.GetFolder(folderPath)
    If Not Evaluate("isref('" & "Summary" & "'!A1)") Then
        Set newWS = Sheets.Add(After:=Sheets(Sheets.Count))
        With newWS
            .Name = "Summary"
            .Range("A1").Resize(, 4).Value = Array("Target Keyword", "Workbook", "Worksheet", "Address")
        End With
    End If
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
    For Each wb In folder.Files
        If wb.Name Like "*xls*" Then
            Set masterWB = Workbooks.Open(wb)
            With Sheets("Quote Form")
                Set fnd = .Range("D:D").Find(response, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    newWS.Cells(newWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(fnd, masterWB.Name, "Quote Form", fnd.Address)
                Else
                    MsgBox (response & " does not exist in 'Quote Form' in " & masterWB.Name)
                End If
            End With
            ActiveWorkbook.Close False
        End If
    Next wb
    For Each subfolder In folder.SubFolders
        For Each wb In subfolder.Files
            If wb.Name Like "*xls*" Then
                Set masterWB = Workbooks.Open(wb)
                With Sheets("Quote Form")
                    Set fnd = .Range("D:D").Find(response, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        newWS.Cells(newWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(fnd, masterWB.Name, "Quote Form", fnd.Address)
                    Else
                        MsgBox (response & " does not exist in 'Quote Form' in " & masterWB.Name)
                    End If
                End With
                ActiveWorkbook.Close False
            End If
        Next wb
    Next subfolder
    With newWS
        .Activate
        .Columns.AutoFit
        .Range("A1").Select
   End With
   With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
End Sub
 
Upvote 0
Give this a try:
VBA Code:
Public Sub searchText()
    Dim FSO As Object, folder As Object, subfolder As Object, newWS As Worksheet, wb As Object, response As String
    response = InputBox("Please enter the search string.")
    If response = "" Then Exit Sub
    Set FSO = CreateObject("Scripting.FileSystemObject")
    folderPath = "C:\Users\paulh\OneDrive -  xxxxLimited\Quote 2020\"
    Set folder = FSO.GetFolder(folderPath)
    If Not Evaluate("isref('" & "Summary" & "'!A1)") Then
        Set newWS = Sheets.Add(After:=Sheets(Sheets.Count))
        With newWS
            .Name = "Summary"
            .Range("A1").Resize(, 4).Value = Array("Target Keyword", "Workbook", "Worksheet", "Address")
        End With
    End If
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
    For Each wb In folder.Files
        If wb.Name Like "*xls*" Then
            Set masterWB = Workbooks.Open(wb)
            With Sheets("Quote Form")
                Set fnd = .Range("D:D").Find(response, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    newWS.Cells(newWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(fnd, masterWB.Name, "Quote Form", fnd.Address)
                Else
                    MsgBox (response & " does not exist in 'Quote Form' in " & masterWB.Name)
                End If
            End With
            ActiveWorkbook.Close False
        End If
    Next wb
    For Each subfolder In folder.SubFolders
        For Each wb In subfolder.Files
            If wb.Name Like "*xls*" Then
                Set masterWB = Workbooks.Open(wb)
                With Sheets("Quote Form")
                    Set fnd = .Range("D:D").Find(response, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fnd Is Nothing Then
                        newWS.Cells(newWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(fnd, masterWB.Name, "Quote Form", fnd.Address)
                    Else
                        MsgBox (response & " does not exist in 'Quote Form' in " & masterWB.Name)
                    End If
                End With
                ActiveWorkbook.Close False
            End If
        Next wb
    Next subfolder
    With newWS
        .Activate
        .Columns.AutoFit
        .Range("A1").Select
   End With
   With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
End Sub
Hi thanks for this

What seems to happen is it checks each file but I have to close manually each time. However it doesn't seem to find the search entered
 
Upvote 0
You shouldn't have to close each file manually. This line of code:
VBA Code:
ActiveWorkbook.Close False
closes each file.
However it doesn't seem to find the search entered
Make sure that you enter the search criteria exactly as it appears in the worksheet. Check the search string in the sheet to make sure it doesn't have any leading or trailing spaces. I have tested the macro on some dummy files and it worked properly. If you are still have problems, please upload a copy of your file containing the "Summary" sheet and a copy of at least one of the other files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
Hi

tried thAt and exactly matched but still no joy

also issue of having to manually close eachfile after it searches

i will sort a generic file and send as soon as I can
 
Upvote 0

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top