Excel VBA search multiple sheets

[jonobono8888]

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!

 

[gallen]

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

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

 

[jonobono8888]

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

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

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!

 

[gallen]

Re: Excel VBA search multiple sheets help

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!

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

Again on primitive data all appears good.

'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

 

[jonobono8888]

Re: Excel VBA search multiple sheets help

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

Thanks so much for your help!

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

Again on primitive data all appears good.

'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

 

[gallen]

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:

'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

 

[jonobono8888]

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?

 

[jonobono8888]

Re: Excel VBA search multiple sheets help

@gallen Any ideas?

 

[gallen]

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.

 

[jonobono8888]

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.

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?

 

[gallen]

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.

'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