Loop to search for partial string across entire table, and paste all rows containing that partial string (in any column) to results page

[TullulahJoy]

Hi all,

Hitting a wall with an attempt to build a specific kind of search function into a workbook. I'm new to Macros and have got myself halfway there between some existing threads on here and youtube tutorials, but I can't work out how to tweak it to what I'm after

I have search page, data page with huge table, and results page. I want the user to enter a search term into the a box, and for Excel to search the table on the data page for that term in all rows - across every column. It may just be one word in a sentence somewhere. If a row contains the term anywhere, I want it copied to the results page.

All I have managed to make work is a macro to search an exact word/phrase in a specific column, but I can't figure out the correct way to expand to all columns, and make it work to identify where the search term appears amongst other text in a cell.

Would appreciate any help!!!

 

[AlphaFrog]

Can you post your code as it is?
Please take note of my signature block below about the use of CODE tags.

 

[TullulahJoy]

Sure thing - see below. Have decided to simplify and just go with Data Page and then a combined search and results page.

I think " If Cells(i, 2) = SearchTerm Then" is why it's stuck on that one column, but I don't know the correct way to tell it to check every cell.
It's also only looking for exact matches, not partial strings, but I have no idea where to start with that!

 Sub finddata()


'Set variables
Dim DataSheet As Worksheet 'where copied from
Dim SearchSheet As Worksheet 'where results go
Dim SearchTerm As String
Dim FinalRow As Integer
Dim i As Integer 'row counter


Set DataSheet = Sheets("Data")
Set SearchSheet = Sheets("Search")
SearchTerm = SearchSheet.Range("B3").Value

'Clear old search results
SearchSheet.Range("B8:I1000").ClearContents

'Open datasheet and search
DataSheet.Select
FinalRow = Range("B10000").End(xlUp).Row

'Loop and find matching records
For i = 8 To FinalRow
    If Cells(i, 2) = SearchTerm Then
        Range(Cells(i, 2), Cells(i, 9)).Copy
        SearchSheet.Select
        Range("B1000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        DataSheet.Select
    End If
    Application.ScreenUpdating = False
Next i


'Make Search Page (with results) active page
SearchSheet.Select
Range("B3").Select
           

End Sub

 

[AlphaFrog]

[color=darkblue]Sub[/color] finddata()
    
    [color=green]'Set variables[/color]
    [color=darkblue]Dim[/color] DataSheet   [color=darkblue]As[/color] Worksheet    [color=green]'where copied from[/color]
    [color=darkblue]Dim[/color] SearchSheet [color=darkblue]As[/color] Worksheet    [color=green]'where results go[/color]
    [color=darkblue]Dim[/color] SearchTerm  [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] Found       [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rngAll      [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] FirstFound  [color=darkblue]As[/color] [color=darkblue]String[/color]
    
    [color=darkblue]Set[/color] DataSheet = Sheets("Data")
    [color=darkblue]Set[/color] SearchSheet = Sheets("Search")
    SearchTerm = SearchSheet.Range("B3").Value
    
    [color=green]'Clear old search results[/color]
    SearchSheet.Range("B8:I" & Rows.Count).ClearContents
    
    [color=darkblue]Set[/color] Found = DataSheet.UsedRange.Find(What:=SearchTerm, _
                                         LookIn:=xlValues, _
                                         LookAt:=xlPart, _
                                         SearchOrder:=xlByRows, _
                                         SearchDirection:=xlNext, _
                                         MatchCase:=False)
                                         
    [color=darkblue]If[/color] [color=darkblue]Not[/color] Found [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
        FirstFound = Found.Address
        [color=darkblue]Set[/color] rngAll = Found.EntireRow.Columns("B:I")
        [color=darkblue]Do[/color]
            [color=darkblue]Set[/color] rngAll = Union(rngAll, Found.EntireRow.Columns("B:I"))
            [color=darkblue]Set[/color] Found = DataSheet.UsedRange.FindNext(After:=Found)
        [color=darkblue]Loop[/color] [color=darkblue]Until[/color] Found.Address = FirstFound
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
    [color=darkblue]If[/color] [color=darkblue]Not[/color] rngAll [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
        rngAll.Copy
        SearchSheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = [color=darkblue]False[/color]
        [color=green]'Make Search Page (with results) active page[/color]
        Application.Goto SearchSheet.Range("B3")
    [color=darkblue]Else[/color]
        MsgBox SearchTerm, vbExclamation, "No Match Found"
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[TullulahJoy]

Amazing. Thank you!

I had to adapt a few bits (mostly columns) to fit with the data in another document, but as far as I know I only changed the columns being returned. The code works perfectly for some search terms, but is returning an error saying for others which is slightly confusing! E.g. I searched 'home' and it was fine. I searched 'Security' and it returns an error saying

'Run time error '1004': We can't do that to a merged cell'


When I debug it highlights 'rngAll.Copy' as the problem. But I don't understand how it can be a problem for one search term, but not the other, as surely the word shouldn't make a difference?


Perhaps when I edited the code for the new document I created an error - if anyone can look at the below and let me know I'd really appreciate it

Sub Find_PartString_AllCells()
    
    'Set variables
    Dim DataSheet   As Worksheet    'where copied from
    Dim SearchSheet As Worksheet    'where results go
    Dim SearchTerm  As String
    Dim Found       As Range
    Dim rngAll      As Range
    Dim FirstFound  As String
    
    Set DataSheet = Sheets("Data")
    Set SearchSheet = Sheets("Search")
    SearchTerm = SearchSheet.Range("C8").Value
    
    'Clear old search results
    SearchSheet.Range("B11:I" & Rows.Count).ClearContents
    
    Set Found = DataSheet.UsedRange.Find(What:=SearchTerm, _
                                         LookIn:=xlValues, _
                                         LookAt:=xlPart, _
                                         SearchOrder:=xlByRows, _
                                         SearchDirection:=xlNext, _
                                         MatchCase:=False)
                                         
    If Not Found Is Nothing Then
        FirstFound = Found.Address
        Set rngAll = Found.EntireRow.Columns("A:F")
        Do
            Set rngAll = Union(rngAll, Found.EntireRow.Columns("A:F"))
            Set Found = DataSheet.UsedRange.FindNext(After:=Found)
        Loop Until Found.Address = FirstFound
    End If
    
    If Not rngAll Is Nothing Then
        rngAll.Copy 'this is where the debug error highlights
        SearchSheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
        
        'Make Search Page (with results) active page
        Application.Goto SearchSheet.Range("C8")
    Else
        MsgBox SearchTerm, vbExclamation, "No Match Found"
    End If
    
End Sub