searchresults added to listbox

[wCJanssen]

Hi there,

My last visit to mrexcel.com got me a great macro that searches a sheet for a user-defined value and pastes any full and partial matches to a different sheet in the same workbook. I would like to adapt this macro a little now though, so that it shows any results in a listbox, in stead of on a sheet. I would greatly appreciate it if anyone could adapt the current code for me:

Private Sub Retrieve_Click()

Dim vFound As Range, rngOutput As Range
Dim strFirstAddress As String
On Error GoTo ErrorHandle
Set vFound = Cells.Find(What:=query.Value, After:=Cells(1, 10), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
With Sheets("Database").Range("Names")
If Not vFound Is Nothing Then
strFirstAddress = vFound.Address
Set rngOutput = ActiveWorkbook.Sheets("Searchresults").Range("A1")
Do
vFound.EntireRow.Copy Destination:=rngOutput
Set rngOutput = rngOutput.Offset(1, 0)
Set vFound = Cells.FindNext(vFound)
Loop Until vFound.Address = strFirstAddress
Else
MsgBox ("Your search does not yield any results")
End If
Exit Sub
ErrorHandle:
If Err.Number = 9 Then
MsgBox ("Error")
Else
MsgBox (Err.Description)
End If '
End With
End Sub

Thanks in advance

 

[John_w]

Try something like this. Put a listbox (single column) from the Control Toolbox on the sheet.

Option Explicit

Private Sub Retrieve_Click()

    Dim vFound As Range
    Dim strFirstAddress As String
    
    On Error GoTo ErrorHandle
    
    Set vFound = Cells.Find(What:=query.Value, After:=Cells(1, 10), _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If Not vFound Is Nothing Then
        strFirstAddress = vFound.Address
        Do
            ListBox1.AddItem CvtRowValues(vFound.Row)
            Set vFound = Cells.FindNext(vFound)
        Loop Until vFound.Address = strFirstAddress
    Else
        MsgBox ("Your search does not yield any results")
    End If
    Exit Sub
ErrorHandle:
    If Err.Number = 9 Then
        MsgBox ("Error")
    Else
        MsgBox (Err.Description)
    End If '
End Sub


Private Function CvtRowValues(rowNumber As Long) As String

    Dim column As Integer
    
    CvtRowValues = ""
    For column = 1 To 6
        CvtRowValues = CvtRowValues & " " & Cells(rowNumber, column).Value
    Next

End Function

I removed your With ... and End With statements because they serve no purpose in your code as posted. You can't use EntireRow.Copy to copy the found row to the listbox, so I've written CvtRowValues which returns a string containing the values of columns 1 to 6 of the found row - you can adapt this as necessary. If you want the listbox to be multi-column, with columns from the sheet populating separate columns in the listbox then more coding is involved.

 

[wCJanssen]

this works perfect; thanks a lot!

 

[DonLeverton]

Thanks John,
This code helped me out as well!
If you want the listbox to be multi-column, with columns from the sheet populating separate columns in the listbox then more coding is involved.

How much more?

I am currently only dealing with 2 columns of data, which are various lengths of text (Here's a small sample) and it would be great to have these items in separate columns in the listbox as well.

Facility Name (Content Variable)	IC-00-T
Fuel	IC-1
Fuel Diesel	IC-1D
Food	IC-2
Trailer Campground	IC-3
Tent Campground	IC-4
Alberta Logo	IC-4-T
Picnic Table	IC-5
Telephone	IC-6
TTY (Tab)	IC-6-T
TTY Phone Sign	IC-6A
Accommodation	IC-7
Travel Information	IC-8
Viewpoint	IC-9
Watchable Wildlife	IC-9-T
Hospital	IC-10
International Airport	IC-11
International Airport Name	IC-11A-T
Municipal Airport	IC-12
Municipal Airport Name	IC-12A-T
Parking	IC-13
Access For Persons with Disabilities	IC-14
Boat Launch	IC-15
Ferry	IC-17
Museum	IC-20
Museum (Tab)	IC-20-T
Bed & Breakfast	IC-21

<colgroup><col><col></colgroup><tbody>
</tbody>

Thanks,
Don

 

[John_w]

Don, I need more details. What are the column letters involved and which column(s) do you want to search?

 

[DonLeverton]

Hi John,

Columns A and B will do it, I think, for now.
I'm hoping to enter a partial text string (eg. "Airport") into cell D1

And would like to see the listbox contain:

International Airport	IC-11
International Airport Name	IC-11A-T
Municipal Airport	IC-12
Municipal Airport Name	IC-12A-T

<tbody>
</tbody>

I've messed around and came up with some "not-so-elegant" code that seem to work ... but I'm definitely open to suggestions for improvement.
============================================
Private Sub cmdFillList_Click()
ListBox1.Clear
Dim rFilter As Range 'range to search
Set rFilter = ActiveSheet.Range("A2", Range("B65536").End(xlUp))
With rFilter
Dim strFind As String
strFind = Range("D1")
Dim vFound As Range
Dim strFirstAddress As String
strFirstAddress = ""
On Error GoTo ErrorHandle

Set vFound = Cells.Find(What:=strFind, After:=Cells(1, 4), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)


If Not vFound Is Nothing And vFound.Address <> Range("$D$1").Address Then
strFirstAddress = vFound.Address

Do
With Me.ListBox1
'Debug.Print vFound.Address
'Debug.Print Range("$D$1").Address
If vFound.Address <> Range("$D$1").Address Then
.AddItem Trim(vFound.Value)
'.List(.ListCount - 1, 0) = vFound.Offset(0, 0).Value
.List(.ListCount - 1, 1) = vFound.Offset(0, 1).Value
End If
End With
Set vFound = Cells.FindNext(vFound)
Loop Until vFound.Address = strFirstAddress

Else
MsgBox ("Your search does not yield any results")
End If
End With
Exit Sub
ErrorHandle:
If Err.Number = 9 Then
MsgBox ("Error")
Else
MsgBox (Err.Description)
End If '


End Sub
=========================================================

The After:= part highlighted above doesn't seem to work the way I had hoped, hence the If statement in the loop.

 

[John_w]

Try this:

1. In a standard module:

Public Sub Search_Range_Populate_ListBox(searchText As String)

    Dim searchRange As Range
    Dim foundCell As Range
    Dim firstAddress As String
    Dim lb As MSForms.ListBox
    
    Set searchRange = ActiveSheet.Columns(1)
    
    Set lb = ActiveSheet.OLEObjects("ListBox1").Object
    lb.Clear
    
    Set foundCell = searchRange.Find(What:=searchText, After:=searchRange.Parent.Cells(Rows.Count, searchRange.column), _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not foundCell Is Nothing Then
        firstAddress = foundCell.Address
        Do
            lb.AddItem foundCell.Value
            lb.column(1, lb.ListCount - 1) = foundCell.Offset(0, 1).Value
            Set foundCell = searchRange.FindNext(foundCell)
        Loop Until foundCell.Address = firstAddress
    Else
        MsgBox """" & searchText & """ not found"
    End If
    
End Sub

2. In the worksheet module of the sheet containing the data (e.g. Sheet1):

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address = "$D$1" Then
        Search_Range_Populate_ListBox Target.Value
    End If
    
End Sub

PS please use CODE tags, like this:

[CODE]
VBA code here
[/CODE]

 

[DonLeverton]

Wow ... that's just perfect!
Thanks so much for the help!