vbs for search help

krrthree

New Member
Joined
Oct 24, 2011
Messages
2
Good evening. I have a 3 sheets. Sheet one contains multiple columns and rows. Sheet 2 is empty, and sheet 3 contains a column of values to search for in column c of sheet one. The following script works with one exception. It only gets the first row with that value and i need it to list all values in column c to return to sheet 2.

Here is the script I am using.

Option Explicit
Sub GeneFinder()
Dim srchLen, gName, nxtRw As Integer
Dim g As Range
'Clear Sheet 2 and Copy Column Headings
Sheets(2).Cells.ClearContents
Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
'Determine length of Search Column from Sheet3
srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
'Loop through list in Sheet3, Column A. As each value is
'found in Sheet1, Column D, copy it top the next row in Sheet2
With Sheets(1).Columns("C")
For gName = 2 To srchLen
Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlWhole)
If Not g Is Nothing Then
nxtRw = Sheets(2).Range("D" & Rows.Count).End(xlUp).Row + 1
g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
End If
Next
End With
End Sub


I don't know how to edit this script in order to get it to return all equal values.

Thanks in advance.
Kenneth
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Code:
Sub GeneFinder()
    Dim srchLen, gName, nxtRw As Integer
    Dim g      As Range
    [COLOR="Red"]Dim FirstFound As String[/COLOR]
    'Clear Sheet 2 and Copy Column Headings
    Sheets(2).Cells.ClearContents
    Sheets(1).Rows(1).Copy Destination:=Sheets(2).Rows(1)
    'Determine length of Search Column from Sheet3
    srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
    'Loop through list in Sheet3, Column A. As each value is
    'found in Sheet1, Column D, copy it top the next row in Sheet2
    With Sheets(1).Columns("C")
        For gName = 2 To srchLen
            Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlWhole)
            If Not g Is Nothing Then
               [COLOR="Red"] FirstFound = g.Address
                Do[/COLOR]
                    nxtRw = Sheets(2).Range("D" & Rows.Count).End(xlUp).Row + 1
                    g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
                    [COLOR="Red"]Set g = .FindNext(g)
                Loop Until g.Address = FirstFound[/COLOR]
            End If
        Next
    End With
End Sub
 
Upvote 0
AlphaFrog

I have had this post up for about 3 hours on two other forums, and you knocked it out quick.

I really appreciate your help.

It is exactly what i have been looking for.

THANKS!!:)
 
Upvote 0
You're welcome.

As a courtesy, reply to the other forums with some sort of "question answered".
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,972
Members
448,537
Latest member
Et_Cetera

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top