Need Help ASAP! Find Multiple Values in One Column, Then Copy Each Entire Row Containing the Values to New Sheet

ThePianoman

New Member
Joined
Mar 15, 2011
Messages
15
I keep coming across the need for this macro in my work projects, so I would be very appreciate to anyone who can help.

I have a sheet containing multiple columns, multiple rows. Column A contains a research participants Subject ID#, and the rest of the rows contain data (gender, visit date, scores from a test, etc.). Each patient may have MULTIPLE rows of data (due to being evaluated on different dates, etc.

My problem is that I don't need the data from EVERY subject that we saw, just from a particular set of subjects. The list of IDs for which I need the data is listed in column A, sheet 3 starting in A2.

I need a Macro that will loop through all of the Subject IDs in column A of sheet 3, then find those subjects in sheet 1 column A (where all the data is stored), then copy the entire row containing that subject ID into sheet 2 on the next available row.

I have a semi-functional Macro that I pulled from another site, but the problem with it is that it won't copy more than 1 row for each subject. Again, each subject may have MULTIPLE rows of data. How do I modify this Macro to find and copy ALL rows containing each subject's ID instead of stopping and moving on to the next subject after finding only one? I would be so appreciative for some help today thanks!!

Option Explicit
Sub PatientFinder()

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 A, copy it top the next row in Sheet2
With Sheets(1).Columns("A")
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("A" & Rows.Count).End(xlUp).Row + 1
g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
End If
Next

End Sub
 

Some videos you may like

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

Watch MrExcel Video

Forum statistics

Threads
1,122,893
Messages
5,598,712
Members
414,254
Latest member
MarieCo

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
Top