VBA: Search for values in a column and copy row to a new sheet for all matching values

[BMurphyNSTG]

Hello,

I am writing a macro in Excel VBA to search for a string (stored in column A) in column B and then paste the row where the match occurs in a new sheet. I started working off of this tutorial, which had almost everything I needed. The difference is that the value I'm searching for in column B keeps changing in column A.
I think I am close, but I keep getting the following error: "Run-time error '1400': Application-defined or object-defined error". I can tell that the code starts working because the correct row is highlighted and my view switches to Sheet2 from Sheet1, but it stops there.

Does anyone know what I need to change in my code to successfully paste the row into Sheet2?

Sub SearchForString()
   Dim ASearchRow As Integer
   Dim BSearchRow As Integer
   Dim CopyToRow As Integer
  ' On Error GoTo Err_Execute
   'Start search in row 2
   ASearchRow = 2
   BSearchRow = 2
   'Start copying data to row 2 in Sheet2 (row counter variable)
   CopyToRow = 2
   'Dim myWS As Worksheet
   'Set myWS = Worksheets("Sheet1")
   'Sheets("Sheet1").Select
   While Len(Range("A" & CStr(ASearchRow)).Value) > 0
      'If value in column B = (what I'm looking for), copy entire row to Sheet2
      If Range("A" & CStr(ASearchRow)).Value = Range("B" & CStr(BSearchRow)).Value Then
       
         'Select row in Sheet1 to copy
         Rows(CStr(BSearchRow) & ":" & CStr(BSearchRow)).Select
         Selection.Copy
         'Paste row into Sheet2 in next row
         Sheets("Sheet2").Select
         Rows(CStr(CopyToRow) & ":" & CStr(CopyToRow)).Select
         ActiveSheet.Paste
         'Move counter to next row
         CopyToRow = CopyToRow + 1
     
         'Go back to Sheet1 to continue searching
         Sheets("Sheet1").Select
         
         Else
         'If the two cells in the same row do not match, the cell in column B will continue looking in the rest of column B
         BSearchRow = BSearchRow + 1
      End If
      'ASearchRow = ASearchRow + 1
   
   Wend
   
'Resetting the B counter to the beginning
BSearchRow = 2
   'Position on cell A3
   Application.CutCopyMode = False
   Range("A2").Select
   MsgBox "All matching data has been copied."
   Exit Sub
Err_Execute:
   MsgBox "An error occurred."
End Sub

Here is the table I'm working with:

column1	dataset
two2	7	a1	a2	a3
three3	three3	b1	b2	b3
four4	5555fivefivefivefive	c1	c2	c3
34thirtyfour	five5	d1	d2	d3
five5	34	e1	e2	e3
21245	two2	f1	f2	f3
6677	five5	g1	g2	g3
63	21245	h1	h2	h3
73	6677	j1	j2	j3
86	63	k1	k2	k3
	73	l1	l2	l3
	86	m1	m2	m3
	four4	n1	n2	n3
	1	o1	o2	o3
	1	p1	p2	p3
	6	q1	q2	q3

<tbody>
</tbody>

 

[yky]

Try this. It should be faster.

Sub SearchForString()   
   Const ASearchRow = 2
   Const BSearchRow = 2
   Dim CopyToRow As Integer
   Dim rng1 As Range
   Dim rng2 As Range
   Dim cell As Range
   Dim found As Range
   
   'Start copying data to row 2 in Sheet2 (row counter variable)
   CopyToRow = 2
   
   Set rng1 = Range(ActiveSheet.Cells(ASearchRow, 1), ActiveSheet.Cells(ASearchRow, 1).End(xlDown))
   Set rng2 = Range(ActiveSheet.Cells(BSearchRow, 2), ActiveSheet.Cells(BSearchRow, 2).End(xlDown))
   
   For Each cell In rng1
   
   Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
   
   If Not found Is Nothing Then
   
   cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)
   
   CopyToRow = CopyToRow + 1
   
   End If
   
   Next cell

End Sub

 

[BMurphyNSTG]

Thank you so much, yky! That worked effortlessly.

As a learning opportunity, do you know what was wrong with my original code?

Try this. It should be faster.

Sub SearchForString()   
   Const ASearchRow = 2
   Const BSearchRow = 2
   Dim CopyToRow As Integer
   Dim rng1 As Range
   Dim rng2 As Range
   Dim cell As Range
   Dim found As Range
   
   'Start copying data to row 2 in Sheet2 (row counter variable)
   CopyToRow = 2
   
   Set rng1 = Range(ActiveSheet.Cells(ASearchRow, 1), ActiveSheet.Cells(ASearchRow, 1).End(xlDown))
   Set rng2 = Range(ActiveSheet.Cells(BSearchRow, 2), ActiveSheet.Cells(BSearchRow, 2).End(xlDown))
   
   For Each cell In rng1
   
   Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
   
   If Not found Is Nothing Then
   
   cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)
   
   CopyToRow = CopyToRow + 1
   
   End If
   
   Next cell

End Sub

 

[yky]

Is this line that's causing the problem?

[COLOR=#333333]Rows(CStr(BSearchRow) & ":" & CStr(BSearchRow)).Select[/COLOR]

You can/should remove all the CStr functions. You can do "Rows(3 & ":" & 5).Select".

By the way, instead of doing select then copy, you want to do copy with destination. For example, you can do this:

Rows("5:8").copy destination:=Range("A15")

This is faster.

 

[jpbcx43]

Hello - I have a similar situation where I have email addresses in both Column A and Column B - there are over 8000 records in Column A, and 3000 in Column B.

I wanted to use this code to search both columns, and if they match, copy the output to the Output tab, however this code appears to just paste values in, even though they don't match.

For example:

After I run the code, this is the output. It appears to be copying all of the data in other columns, however the email addresses aren't matching:

Any way that I can find each of the matching values from Column A and B, take the email address and all other associated columns according to Column B's email address, and output like so (in this case, there are only 4 matches)