Excel VBA search multiple sheets

J

jonobono8888

New Member
Joined
Jan 28, 2019
Messages
14
Hi All,

I have this workbook which contains one summary page and numerous other worksheets which have rows containing different restricted substances according to regulations. Each of these substances have different identification numbers (CAS), EC Numbers and Regulations which are labelled as separate columns. (i.e. Col A = Substance, Col B = CAS, Col C = EC #, etc). Note: Not all worksheets has the same info – so some may have extra data like description, websites where you can find it, some may have less (it’s not consistent since it’s copy and pasted from different sources).

Essentially, I’d like to have a search function on the first worksheet “Sheet1” (so exclude summary page) which would create a list of data returned from all those regulation worksheets. There will sometimes be more than one incidence of the substances or EC number in different worksheets. This is good – I want to see if the substance is in multiple regulations. If the substance or EC number is found in any of the worksheets, I’d like the macro to return specific information from worksheet – namely the substance, CAS Number, EC Number (if available), and the regulation it’s from (another column).

I’ve googled searchable lists and other macros which do similar things to this but I think the main problem will be:

  1. Skipping the summary page for searching
  2. Returning specific information from each column for each worksheet and putting it into the right spot on the main search page.

If anyone could help me out I’d be ever so grateful. Thanks! If you need clarification please let me know and I’ll get back to you. If you need me to send the file, please pm me!
 
Sort by date Sort by votes
Re: Excel VBA search multiple sheets help

1 issue at a time.

To search a single sheet just check that the sheet name = the name of the sheet

Code: 
If sh.Name [COLOR=#ff0000][B]= "YOURSHEETNAME"[/B][/COLOR] Then
            'try to find
            Set rFind = sh.UsedRange.Find(sSearch)
            
            If Not rFind Is Nothing Then 'search is found
                'record the first address
                sFirst = rFind.Address
AddRow:
                'Create a new row
                Set NewRow = tblResults.ListRows.Add
    
                NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colSubstance)
                NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colCASNumber)
                NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colECNumber)
                NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colRegulation)
                NewRow.Range.Cells(1, 5) = sh.Name & "[" & rFind.Address & "]"
                
                'continue searching the sheet for more instances
                Set rFind = sh.UsedRange.FindNext(rFind)
                'if found in a different loaction than the first one, add that row too
                If rFind.Address <> sFirst Then GoTo AddRow
            End If
            
        End If
        'reset find variable
        Set rFind = Nothing
    Next sh
 
Last edited:
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Re: Excel VBA search multiple sheets help

gallen said:
1 issue at a time.

To search a single sheet just check that the sheet name = the name of the sheet

Code: 
If sh.Name [COLOR=#ff0000][B]= "YOURSHEETNAME"[/B][/COLOR] Then
            'try to find
            Set rFind = sh.UsedRange.Find(sSearch)
            
            If Not rFind Is Nothing Then 'search is found
                'record the first address
                sFirst = rFind.Address
AddRow:
                'Create a new row
                Set NewRow = tblResults.ListRows.Add
    
                NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colSubstance)
                NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colCASNumber)
                NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colECNumber)
                NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colRegulation)
                NewRow.Range.Cells(1, 5) = sh.Name & "[" & rFind.Address & "]"
                
                'continue searching the sheet for more instances
                Set rFind = sh.UsedRange.FindNext(rFind)
                'if found in a different loaction than the first one, add that row too
                If rFind.Address <> sFirst Then GoTo AddRow
            End If
            
        End If
        'reset find variable
        Set rFind = Nothing
    Next sh
Click to expand...


Yep - thanks - that fixed the multiple sheets issue.

What do I do for the other two parts?
1) Preventing multiple copies of the same row being presented in the results table. E.g. if I search for a word and it comes up in multiple columns for that row, then the row is copied over the number of times it has been found.
2) Keeping the conditional formatting/ all the formatting from the Main Database sheet when it is being copied over to the search box page?

Thanks again for your help!
 
Upvote 0
Re: Excel VBA search multiple sheets help

jonobono8888 said:
Yep - thanks - that fixed the multiple sheets issue.

What do I do for the other two parts?
1) Preventing multiple copies of the same row being presented in the results table. E.g. if I search for a word and it comes up in multiple columns for that row, then the row is copied over the number of times it has been found.
2) Keeping the conditional formatting/ all the formatting from the Main Database sheet when it is being copied over to the search box page?

Thanks again for your help!
Click to expand...

Here is the complete code. I've highlighted the changes.

Again on primitive data all appears good.

Code: 
'These constants represent the column numbers of each of the desired results
'change where necessary
Const colSubstance As Integer = 1
Const colCASNumber As Integer = 2
Const colECNumber As Integer = 3
Const colRegulation As Integer = 4


Sub DoSearch()
    'this code relies on a defined table existing on sheet1 and that it is the first table on the sheet
    Dim shSearch As Worksheet, sh As Worksheet
    Dim sSearch As String 'search term to find
    Dim rFind As Range 'used to search
    Dim sFirst As String 'used to record the address of the first instance of
    Dim tblResults As ListObject
    Dim NewRow As ListRow
[COLOR=#ff0000][B]    Dim lCurrentRow As Long 'to denote if next instance of word is in same row.[/B][/COLOR]

    Set shSearch = Worksheets("Sheet1")
    
    'set the table variable for easier coding
    Set tblResults = shSearch.ListObjects(1)
    
    'clear the table
    On Error Resume Next
    tblResults.DataBodyRange.EntireRow.Delete
'    With tblResults
'        .DataBodyRange.Rows(1).ClearContents 'clear first row
'        'Delete all other rows. Will error if none exist
'        .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
'    End With
    On Error GoTo 0
    
    'get the search term, removing any leading or trailing spaces
    sSearch = Trim(shSearch.Range("A1"))
    
    'ignore blank search
    If Len(sSearch) = 0 Then Exit Sub
    
    'Loop through all sheets
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shSearch.Name Then
            'try to find
            Set rFind = sh.UsedRange.Find(sSearch)
            
            If Not rFind Is Nothing Then 'search is found
                'record the first address
                sFirst = rFind.Address
                [COLOR=#ff0000][B]lCurrentRow = rFind.Row 'Remember the current row[/B][/COLOR]
AddRow:
                'Create a new row
                Set NewRow = tblResults.ListRows.Add
    
                NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colSubstance)
                NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colCASNumber)
                NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colECNumber)
                NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colRegulation)
                NewRow.Range.Cells(1, 5) = sh.Name & "[" & rFind.Address & "]"
                'These lines copy the formatting over
[COLOR=#ff0000][B]                rFind.EntireRow.Copy[/B][/COLOR]
[COLOR=#ff0000][B]                NewRow.Range.PasteSpecial xlPasteFormats[/B][/COLOR]
                
                'continue searching the sheet for more instances
                Set rFind = sh.UsedRange.FindNext(rFind)
                'if found in a different loaction than the first one, add that row too if the row number is different
                If rFind.Address <> sFirst [COLOR=#ff0000][B]And rFind.Row <> lCurrentRow[/B][/COLOR] Then GoTo AddRow
            End If
            
        End If
        'reset find variable
        Set rFind = Nothing
    Next sh
    
End Sub
 
Last edited:
Upvote 0
Re: Excel VBA search multiple sheets help

Awesome. It works perfectly. You're amazing @gallen

Thanks so much for your help!

gallen said:
Here is the complete code. I've highlighted the changes.

Again on primitive data all appears good.

Code: 
'These constants represent the column numbers of each of the desired results
'change where necessary
Const colSubstance As Integer = 1
Const colCASNumber As Integer = 2
Const colECNumber As Integer = 3
Const colRegulation As Integer = 4


Sub DoSearch()
    'this code relies on a defined table existing on sheet1 and that it is the first table on the sheet
    Dim shSearch As Worksheet, sh As Worksheet
    Dim sSearch As String 'search term to find
    Dim rFind As Range 'used to search
    Dim sFirst As String 'used to record the address of the first instance of
    Dim tblResults As ListObject
    Dim NewRow As ListRow
[COLOR=#ff0000][B]    Dim lCurrentRow As Long 'to denote if next instance of word is in same row.[/B][/COLOR]

    Set shSearch = Worksheets("Sheet1")
    
    'set the table variable for easier coding
    Set tblResults = shSearch.ListObjects(1)
    
    'clear the table
    On Error Resume Next
    tblResults.DataBodyRange.EntireRow.Delete
'    With tblResults
'        .DataBodyRange.Rows(1).ClearContents 'clear first row
'        'Delete all other rows. Will error if none exist
'        .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
'    End With
    On Error GoTo 0
    
    'get the search term, removing any leading or trailing spaces
    sSearch = Trim(shSearch.Range("A1"))
    
    'ignore blank search
    If Len(sSearch) = 0 Then Exit Sub
    
    'Loop through all sheets
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shSearch.Name Then
            'try to find
            Set rFind = sh.UsedRange.Find(sSearch)
            
            If Not rFind Is Nothing Then 'search is found
                'record the first address
                sFirst = rFind.Address
                [COLOR=#ff0000][B]lCurrentRow = rFind.Row 'Remember the current row[/B][/COLOR]
AddRow:
                'Create a new row
                Set NewRow = tblResults.ListRows.Add
    
                NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colSubstance)
                NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colCASNumber)
                NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colECNumber)
                NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colRegulation)
                NewRow.Range.Cells(1, 5) = sh.Name & "[" & rFind.Address & "]"
                'These lines copy the formatting over
[COLOR=#ff0000][B]                rFind.EntireRow.Copy[/B][/COLOR]
[COLOR=#ff0000][B]                NewRow.Range.PasteSpecial xlPasteFormats[/B][/COLOR]
                
                'continue searching the sheet for more instances
                Set rFind = sh.UsedRange.FindNext(rFind)
                'if found in a different loaction than the first one, add that row too if the row number is different
                If rFind.Address <> sFirst [COLOR=#ff0000][B]And rFind.Row <> lCurrentRow[/B][/COLOR] Then GoTo AddRow
            End If
            
        End If
        'reset find variable
        Set rFind = Nothing
    Next sh
    
End Sub
Click to expand...
 
Upvote 0
Re: Excel VBA search multiple sheets help

Thank you, but I think I've seen a bug. It doesn't set the 'lCurrentRow' within the loop. It needs moving to somewhere below the 'AddRow:' line. As it stands it will work where there are 2 instances of the search term but if there are 3+ it will fail.

Just drop the line down:

Code: 
'These constants represent the column numbers of each of the desired results
'change where necessary
Const colSubstance As Integer = 1
Const colCASNumber As Integer = 2
Const colECNumber As Integer = 3
Const colRegulation As Integer = 4




Sub DoSearch()
    'this code relies on a defined table existing on sheet1 and that it is the first table on the sheet
    Dim shSearch As Worksheet, sh As Worksheet
    Dim sSearch As String 'search term to find
    Dim rFind As Range 'used to search
    Dim sFirst As String 'used to record the address of the first instance of
    Dim tblResults As ListObject
    Dim NewRow As ListRow
    Dim lCurrentRow As Long 'to denote if next instance of word is in same row.


    Set shSearch = Worksheets("Sheet1")
    
    'set the table variable for easier coding
    Set tblResults = shSearch.ListObjects(1)
    
    'clear the table
    On Error Resume Next
    tblResults.DataBodyRange.EntireRow.Delete
'    With tblResults
'        .DataBodyRange.Rows(1).ClearContents 'clear first row
'        'Delete all other rows. Will error if none exist
'        .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
'    End With
    On Error GoTo 0
    
    'get the search term, removing any leading or trailing spaces
    sSearch = Trim(shSearch.Range("A1"))
    
    'ignore blank search
    If Len(sSearch) = 0 Then Exit Sub
    
    'Loop through all sheets
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> shSearch.Name Then
            'try to find
            Set rFind = sh.UsedRange.Find(sSearch)
            
            If Not rFind Is Nothing Then 'search is found
                'record the first address
                sFirst = rFind.Address
                
AddRow:
                'record current row:
[COLOR=#ff0000][B]                lCurrentRow = rFind.Row[/B][/COLOR]
                'Create a new row
                Set NewRow = tblResults.ListRows.Add
                
                NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colSubstance)
                NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colCASNumber)
                NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colECNumber)
                NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colRegulation)
                NewRow.Range.Cells(1, 5) = sh.Name & "[" & rFind.Address & "]"
                
                'These lines copy the formatting over
                rFind.EntireRow.Copy
                NewRow.Range.PasteSpecial xlPasteFormats
                
                'continue searching the sheet for more instances
                Set rFind = sh.UsedRange.FindNext(rFind)
                'if found in a different loaction than the first one, add that row too if the row number is different
                If rFind.Address <> sFirst And rFind.Row <> lCurrentRow Then GoTo AddRow
            End If
            
        End If
        'reset find variable
        Set rFind = Nothing
    Next sh
    
End Sub
 
Upvote 0
Re: Excel VBA search multiple sheets help

Ok so I've implemented the change. I've just realised there's a problem with the code.

Whenever I search an item which has a keyword for multiple rows, it only shows one row. (i.e. If a subassembly has the word "frame" in it, only the first row containing that word comes up - the others aren't picked up).

How can I fix this?
 
Upvote 0
Re: Excel VBA search multiple sheets help

I think I may have misunderstood.

I've tested and it seems to work. If the search word appears in different rows then each row it appears in copied over.
 
Upvote 0
Re: Excel VBA search multiple sheets help

gallen said:
I think I may have misunderstood.

I've tested and it seems to work. If the search word appears in different rows then each row it appears in copied over.
Click to expand...

So below is my current code:

'These constants represent the column numbers of each of the desired results
'change where necessary
Const colBusiness As Integer = 1
Const colDevice As Integer = 2
Const colProject As Integer = 3
Const colAssembly As Integer = 4
Const colAssemblyPart As Integer = 5
Const colComponent As Integer = 6
Const colComponentNum As Integer = 7
Const colClaiganNum As Integer = 8
Const colMatSup As Integer = 9
Const colMatType As Integer = 10
Const colMatInfo As Integer = 11
Const colCode As Integer = 12
Const colPatientCont As Integer = 13
Const colPatientDura As Integer = 14
Const colBiocompatibility As Integer = 15
Const colBioReport As Integer = 16
Const colEUMDRYR As Integer = 17
Const colSubsRep As Integer = 18
Const colEUMDR104 As Integer = 19
Const colEUMDR234 As Integer = 20
Const colReachSVHC As Integer = 21
Const colReachRest As Integer = 22
Const colCaProp As Integer = 23
Const colWEEE As Integer = 24
Const colROHS2 As Integer = 25
Const colROHS3 As Integer = 26
Const colEUPOP As Integer = 27
Const colPFOA As Integer = 28
Const colAUAsbestos As Integer = 29




Sub DoSearch()
'this code relies on a defined table existing on sheet1 and that it is the first table on the sheet
Dim shSearch As Worksheet, sh As Worksheet
Dim sSearch As String 'search term to find
Dim rFind As Range 'used to search
Dim sFirst As String 'used to record the address of the first instance of
Dim tblResults As ListObject
Dim NewRow As ListRow
Dim sName As String
Dim sFound As Boolean
Dim lCurrentRow As Long 'to denote if next instance of word is in same row


Set shSearch = Worksheets("Search Database")
Set dbSearch = Worksheets("Main Database")

'set the table variable for easier coding
Set tblResults = shSearch.ListObjects(1)

'clear the table
On Error Resume Next
tblResults.DataBodyRange.EntireRow.Delete
' With tblResults
' .DataBodyRange.Rows(1).ClearContents 'clear first row
' 'Delete all other rows. Will error if none exist
' .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
' End With
On Error GoTo 0

'get the search term, removing any leading or trailing spaces
sSearch = Trim(shSearch.Range("B2"))

'ignore blank search
If Len(sSearch) = 0 Then Exit Sub

'Loop through all sheets
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "Main Database" Then
'try to find
Set rFind = sh.UsedRange.Find(sSearch)

If Not rFind Is Nothing Then 'search is found
'record the first address
sFirst = rFind.Address

AddRow:
'record current row:
lCurrentRow = rFind.Row
'Create a new row
Set NewRow = tblResults.ListRows.Add

NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colBusiness)
NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colDevice)
NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colProject)
NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colAssembly)
NewRow.Range.Cells(1, 5) = sh.Cells(rFind.Row, colAssemblyPart)
NewRow.Range.Cells(1, 6) = sh.Cells(rFind.Row, colComponent)
NewRow.Range.Cells(1, 7) = sh.Cells(rFind.Row, colComponentNum)
NewRow.Range.Cells(1, 8) = sh.Cells(rFind.Row, colClaiganNum)
NewRow.Range.Cells(1, 9) = sh.Cells(rFind.Row, colMatSup)
NewRow.Range.Cells(1, 10) = sh.Cells(rFind.Row, colMatType)
NewRow.Range.Cells(1, 11) = sh.Cells(rFind.Row, colMatInfo)
NewRow.Range.Cells(1, 12) = sh.Cells(rFind.Row, colCode)
NewRow.Range.Cells(1, 13) = sh.Cells(rFind.Row, colPatientCont)
NewRow.Range.Cells(1, 14) = sh.Cells(rFind.Row, colPatientDura)
NewRow.Range.Cells(1, 15) = sh.Cells(rFind.Row, colBiocompatibility)
NewRow.Range.Cells(1, 16) = sh.Cells(rFind.Row, colBioReport)
NewRow.Range.Cells(1, 17) = sh.Cells(rFind.Row, colEUMDRYR)
NewRow.Range.Cells(1, 18) = sh.Cells(rFind.Row, colSubsRep)
NewRow.Range.Cells(1, 19) = sh.Cells(rFind.Row, colEUMDR104)
NewRow.Range.Cells(1, 20) = sh.Cells(rFind.Row, colEUMDR234)
NewRow.Range.Cells(1, 21) = sh.Cells(rFind.Row, colReachSVHC)
NewRow.Range.Cells(1, 22) = sh.Cells(rFind.Row, colReachRest)
NewRow.Range.Cells(1, 23) = sh.Cells(rFind.Row, colCaProp)
NewRow.Range.Cells(1, 24) = sh.Cells(rFind.Row, colWEEE)
NewRow.Range.Cells(1, 25) = sh.Cells(rFind.Row, colROHS2)
NewRow.Range.Cells(1, 26) = sh.Cells(rFind.Row, colROHS3)
NewRow.Range.Cells(1, 27) = sh.Cells(rFind.Row, colEUPOP)
NewRow.Range.Cells(1, 28) = sh.Cells(rFind.Row, colPFOA)
NewRow.Range.Cells(1, 29) = sh.Cells(rFind.Row, colAUAsbestos)
'NewRow.Range.Cells(1, 30) = sh.Name & "[" & rFind.Address & "]"
'continue searching the sheet for more instances

'These lines copy the formatting over
rFind.EntireRow.Copy
NewRow.Range.PasteSpecial xlPasteFormats

'continue searching the sheet for more instances
Set rFind = sh.UsedRange.FindNext(rFind)
'if found in a different loaction than the first one, add that row too if the row number is different
If rFind.Address <> sFirst And rFind.Row <> lCurrentRow Then GoTo AddRow


End If



End If
'reset find variable
Set rFind = Nothing
Next sh

End Sub


The main problem which I'm experiencing is that if I search a term in the Main database which is shown in multiple rows (e.g. frame, project name, etc) only one row of that data will come up (even though i know there should be at least 20+ rows which contains that word).
I'm thinking it may be an issue with this line?
'continue searching the sheet for more instances
Set rFind = sh.UsedRange.FindNext(rFind)
'if found in a different loaction than the first one, add that row too if the row number is different
If rFind.Address <> sFirst And rFind.Row <> lCurrentRow Then GoTo AddRow

Based off your response - I think you know what I mean and what the problem is but it's just that the problem isn't replicating for you?
 
Upvote 0
Re: Excel VBA search multiple sheets help

I'm posting this so we have an easy to read code block. If you use the code tags when posting codes makes it infinitely easier for people to read.

Any reply will be in subsequent posts.

Code: 
'These constants represent the column numbers of each of the desired results

'change where necessary
Const colBusiness As Integer = 1
Const colDevice As Integer = 2
Const colProject As Integer = 3
Const colAssembly As Integer = 4
Const colAssemblyPart As Integer = 5
Const colComponent As Integer = 6
Const colComponentNum As Integer = 7
Const colClaiganNum As Integer = 8
Const colMatSup As Integer = 9
Const colMatType As Integer = 10
Const colMatInfo As Integer = 11
Const colCode As Integer = 12
Const colPatientCont As Integer = 13
Const colPatientDura As Integer = 14
Const colBiocompatibility As Integer = 15
Const colBioReport As Integer = 16
Const colEUMDRYR As Integer = 17
Const colSubsRep As Integer = 18
Const colEUMDR104 As Integer = 19
Const colEUMDR234 As Integer = 20
Const colReachSVHC As Integer = 21
Const colReachRest As Integer = 22
Const colCaProp As Integer = 23
Const colWEEE As Integer = 24
Const colROHS2 As Integer = 25
Const colROHS3 As Integer = 26
Const colEUPOP As Integer = 27
Const colPFOA As Integer = 28
Const colAUAsbestos As Integer = 29

Sub DoSearch()
'this code relies on a defined table existing on sheet1 and that it is the first table on the sheet
Dim shSearch As Worksheet, sh As Worksheet
Dim sSearch As String 'search term to find
Dim rFind As Range 'used to search
Dim sFirst As String 'used to record the address of the first instance of
Dim tblResults As ListObject
Dim NewRow As ListRow
Dim sName As String
Dim sFound As Boolean
Dim lCurrentRow As Long 'to denote if next instance of word is in same row

    Set shSearch = Worksheets("Search Database")
    Set dbSearch = Worksheets("Main Database")
    
    'set the table variable for easier coding
    Set tblResults = shSearch.ListObjects(1)
    
    'clear the table
    On Error Resume Next
    tblResults.DataBodyRange.EntireRow.Delete
    
    On Error GoTo 0
    
    'get the search term, removing any leading or trailing spaces
    sSearch = Trim(shSearch.Range("B2"))
    
    'ignore blank search
    If Len(sSearch) = 0 Then Exit Sub
    
    'Loop through all sheets
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name = "Main Database" Then
            'try to find
            Set rFind = sh.UsedRange.Find(sSearch)
            
            If Not rFind Is Nothing Then 'search is found
                'record the first address
                sFirst = rFind.Address
                
AddRow:
                'record current row:
                lCurrentRow = rFind.Row
                'Create a new row
                Set NewRow = tblResults.ListRows.Add
                
                NewRow.Range.Cells(1, 1) = sh.Cells(rFind.Row, colBusiness)
                NewRow.Range.Cells(1, 2) = sh.Cells(rFind.Row, colDevice)
                NewRow.Range.Cells(1, 3) = sh.Cells(rFind.Row, colProject)
                NewRow.Range.Cells(1, 4) = sh.Cells(rFind.Row, colAssembly)
                NewRow.Range.Cells(1, 5) = sh.Cells(rFind.Row, colAssemblyPart)
                NewRow.Range.Cells(1, 6) = sh.Cells(rFind.Row, colComponent)
                NewRow.Range.Cells(1, 7) = sh.Cells(rFind.Row, colComponentNum)
                NewRow.Range.Cells(1, 8) = sh.Cells(rFind.Row, colClaiganNum)
                NewRow.Range.Cells(1, 9) = sh.Cells(rFind.Row, colMatSup)
                NewRow.Range.Cells(1, 10) = sh.Cells(rFind.Row, colMatType)
                NewRow.Range.Cells(1, 11) = sh.Cells(rFind.Row, colMatInfo)
                NewRow.Range.Cells(1, 12) = sh.Cells(rFind.Row, colCode)
                NewRow.Range.Cells(1, 13) = sh.Cells(rFind.Row, colPatientCont)
                NewRow.Range.Cells(1, 14) = sh.Cells(rFind.Row, colPatientDura)
                NewRow.Range.Cells(1, 15) = sh.Cells(rFind.Row, colBiocompatibility)
                NewRow.Range.Cells(1, 16) = sh.Cells(rFind.Row, colBioReport)
                NewRow.Range.Cells(1, 17) = sh.Cells(rFind.Row, colEUMDRYR)
                NewRow.Range.Cells(1, 18) = sh.Cells(rFind.Row, colSubsRep)
                NewRow.Range.Cells(1, 19) = sh.Cells(rFind.Row, colEUMDR104)
                NewRow.Range.Cells(1, 20) = sh.Cells(rFind.Row, colEUMDR234)
                NewRow.Range.Cells(1, 21) = sh.Cells(rFind.Row, colReachSVHC)
                NewRow.Range.Cells(1, 22) = sh.Cells(rFind.Row, colReachRest)
                NewRow.Range.Cells(1, 23) = sh.Cells(rFind.Row, colCaProp)
                NewRow.Range.Cells(1, 24) = sh.Cells(rFind.Row, colWEEE)
                NewRow.Range.Cells(1, 25) = sh.Cells(rFind.Row, colROHS2)
                NewRow.Range.Cells(1, 26) = sh.Cells(rFind.Row, colROHS3)
                NewRow.Range.Cells(1, 27) = sh.Cells(rFind.Row, colEUPOP)
                NewRow.Range.Cells(1, 28) = sh.Cells(rFind.Row, colPFOA)
                NewRow.Range.Cells(1, 29) = sh.Cells(rFind.Row, colAUAsbestos)
                'continue searching the sheet for more instances
                
                'These lines copy the formatting over
                rFind.EntireRow.Copy
                NewRow.Range.PasteSpecial xlPasteFormats
                
                'continue searching the sheet for more instances
                Set rFind = sh.UsedRange.FindNext(rFind)
                'if found in a different loaction than the first one, add that row too if the row number is different
                If rFind.Address <> sFirst And rFind.Row <> lCurrentRow Then GoTo AddRow
            
            End If
        
        End If
        'reset find variable
        Set rFind = Nothing
    Next sh

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
VBA to perform Text Diff (but with >2500 Char per cell)
Replies
0
Views
260
potatoooooooo
P
C
  • Solved
List Results from All Sheets Search
2
Replies
16
Views
215
MikeVol
MikeVol
B
  • Solved
Search vlookup more than 1 column
2 3
Replies
23
Views
476
DanteAmor
DanteAmor
X
  • Question Question
VBA for extracting specific data from PDF Docs
Replies
3
Views
645
xcellrodeo
X
R
  • Solved
I need to find a row based on multiple criteria, with a catch.
2
Replies
13
Views
1K
rcrumbliss
R

Forum statistics

Threads
1,223,911
Messages
6,175,333
Members
452,636
Latest member
laura12345

Share this page

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