Copy Rows To Listbox

[Jaye7]

Hi All,

Can someone please help with the following.

I am using the following script which highlights the entire row of found values.

I would like a modified script which would copy the rows of the found values into a listbox.

Also a script which would copy not the entire row of the found values into the listbox but values in columns A, C, F, G of the found values.

Lastly a script which would copy the rows of the found values from sheet named contacts to sheet named contacts2.

Sub Test()
 
    Dim hCell As Range
    Dim strName As String
    ReDim arr(4) As String
    Dim rw, i As Long
 
    ' change the following values to what you want, non case senstive
    arr(1) = Sheets("Contacts").Range("A3").Value
    arr(2) = "Temp1"
    arr(3) = "Temp2"
    arr(4) = "Temp3"
 
    For Each hCell In Sheets("Contacts").Range("A4:A2000")
 
        For i = 1 To UBound(arr)
 
            strName = arr(i)
            Set FOUND = hCell.Find(strName, , , xlPart)
            If Not FOUND Is Nothing Then
                rw = hCell.Find(strName, , , xlPart).Row
 
                Rows(rw).EntireRow.Interior.ColorIndex = 6
 
                ' copy row values into listbox1
 
 
            Else: End If
 
        Next i
 
    Next
 
End Sub

 

[Worf]

See if this is useful for you...

Option Explicit
Option Base 1
Sub TestListBox()
 ' requested by jaye7
    Dim hCell As Range, strName$, FOUND As Range, AllRow As Boolean
    Dim arr$(1 To 4), rw, i&, j%, sn(1 To 2) As Worksheet, cn(), LR%
    Set sn(1) = ThisWorkbook.Worksheets("Contacts")
    Set sn(2) = ThisWorkbook.Worksheets("Contacts2")    ' found data goes here
    cn = Array(1, 3, 6, 7)                  ' column numbers
    arr(1) = sn(1).Range("A3").Value
    arr(2) = "Temp1"
    arr(3) = "Temp2":    arr(4) = "Temp3"
    AllRow = True                          ' whether to copy entire row or not
    sn(2).Cells.ClearContents
        
    For Each hCell In sn(1).Range("A4:A20")
         For i = 1 To UBound(arr)
            strName = arr(i)
            Set FOUND = hCell.Find(strName, , , xlPart)
            If Not FOUND Is Nothing Then
                rw = hCell.Find(strName, , , xlPart).Row
                sn(1).Rows(rw).Interior.ColorIndex = 6
                Select Case AllRow
                    Case True
                        sn(2).Rows(LastRow(sn(2).Name) + 1).Value = sn(1).Rows(rw).Value
                    Case False
                        LR = LastRow(sn(2).Name) + 1
                        For j = 1 To 4
                            sn(2).Cells(LR, j).Value = sn(1).Cells(rw, cn(j)).Value
                        Next
                End Select
            Else: End If
         Next i
    Next
    With UserForm1.ListBox1
        .ColumnCount = sn(2).UsedRange.Columns.Count
        .BoundColumn = 1
        .RowSource = sn(2).UsedRange.Address
    End With
    UserForm1.Show
     
End Sub
Public Function LastRow(ws$) As Long
    Worksheets(ws).Activate
    If WorksheetFunction.CountA(Cells) = 0 Then
        LastRow = 0
        Exit Function
    End If
    LastRow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
End Function

 

[Jaye7]

Thanks for your help Worf,

I tested using the allrows script and then the specific columns script and it worked well for both.

Much appreciated.

 

[Worf]

You are welcome.