Excel VBA search engine code help

[dan_sherbs]

Hi,

I'm trying to create a searchable knowledge database in Excel & having a bit of trouble editing some code i found to fit my requirements.

Basically I have a number of different worksheets representing different locations. They all have the same look and feel to them with rows of questions in column B and the corresponding answer in Column C.

I then have another worksheet called "Search". I want the user to enter a word/String in Cell B2, select the location from a drop down box in Cell B3, click a search button which runs a macro/some VBA code that displays all the results from Row 7 down with the question in column A and the answer is in Column B. Note I would like it so the word entered by the user is searched in both the question and answer columns and results displayed accodingly. (for example if the word "London" is in a question and also in another answer then the results will display both.

I have seen the following code which nearly gets what i want, is anybody able to provide some help how i modify this to make my requirement?

Many Thanks, code below..

Dan

Sub SearchParts()
 Dim arrParts() As Variant
    Range("A7", "B" & Cells(Rows.CountLarge, "B").End(xlDown).Row).Clear
    arrParts = FindParts(CStr(Trim(Cells(2, 2))))
    Range("A7").Resize(UBound(arrParts, 2), UBound(arrParts)) = _
        WorksheetFunction.Transpose(arrParts)
End Sub

Private Function FindParts(PartNumber As String) As Variant
Dim ws As Worksheet
Dim FoundCell As Range
Dim LastCell As Range
Dim rngParts As Range
Dim FirstAddr As String
Dim arrPart() As Variant
    Set ws = Worksheets("Data")
    Set rngParts = ws.Range("A2:B" & ws.Cells(Rows.CountLarge, "B").End(xlUp).Row)
    With rngParts
        Set LastCell = .Cells(.Cells.Count)
    End With
    Set FoundCell = rngParts.Find(What:=PartNumber, After:=LastCell, LookAt:=xlPart)
    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    
    ReDim arrPart(1 To 2, 1 To 1)
    Do Until FoundCell Is Nothing
        arrPart(1, UBound(arrPart, 2)) = FoundCell.Offset(0, -1)
        arrPart(2, UBound(arrPart, 2)) = FoundCell.Value
                
        ReDim Preserve arrPart(1 To 2, 1 To UBound(arrPart, 2) + 1)
        Set FoundCell = rngParts.FindNext(After:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    FindParts = arrPart
End Function

 

[Chris Mack]

Hi there,

I'm not sure about the code you already have, but this is working for me:

Sub Search()
    If Cells(6, 1) = "" Then Cells(6, 1) = "-"
    pg = CStr(Cells(3, 2))
    term = LCase(CStr(Cells(2, 2)))
    n = Sheets(pg).Cells(Rows.Count, 2).End(xlUp).Row
    For r = 1 To n
        If InStr(1, LCase(Sheets(pg).Cells(r, 2)), term) > 0 Or InStr(1, LCase(Sheets(pg).Cells(r, 3)), term) > 0 Then
            k = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(k, 1) = Sheets(pg).Cells(r, 2)
            Cells(k, 2) = Sheets(pg).Cells(r, 3)
        End If
    Next
    If Cells(6, 1) = "-" Then Cells(6, 1).ClearContents
End Sub

Note: The first and last lines (highlighted) are really there because I'm not sure if you have a heading or anything in A6 - if you do then you don't need those lines.

Hope this helps,

Chris.

 

[dan_sherbs]

Hi Simon,

Thanks, nearly works.

The issues i have with it compared to the other code is the following:

1. you press the button again and it appends the same resulting row underneath (i.e. the same question and answer - will repeat everytime you hit the button)
2. If i type something else in the search cell it appends underneath previous results rather than just displaying the results from the current search

Can you help fix?

Many Thanks
Dan

 

[dan_sherbs]

Sorry I meant Chris! was confusing myself with emailing someone called Simon at work lol

Anyway i hope you have a solution to help me fix those last 2 issues, nearly there!

Many Thanks

 

[Chris Mack]

Ah, yes, I didn't consider that.

Adding...

    Rows("7:" & Rows.Count).Delete

... to the start of the code should fix it.

Chris

 

[dan_sherbs]

Perfect! Thanks very much!

Any other cool little features i can add to it to enhance it let me know

Cheers
Dan

 

[Chris Mack]

Yw!

 

[dan_sherbs]

sorry one last thing, everytime i hit the button it wipes out any formatting i've done. I want the Question & answer columns to be permanently horizontally Justified, do you have some additional code that can solve this?

Cheers

 

[Chris Mack]

In that last line of code I posted, switch "Delete" with "ClearContents".

Chris