Copy Row To A New Sheet If A Value Found In Adjacent Column

[Rajesh Kr Joshi]

Hi,

I was searching for a macro to search a value Question 1 in column E and copy the rows having Question 1 value to Sheet2. The below code exactly does the same thing. But I am searching for 3 different values (Question 1, Question 2 and Question 3) and wants to copy the rows having these values in 3 separates sheets. Can you please help in modifying the code to meet the goal.


Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 4
LSearchRow = 4

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub

Here's the sample file that uses the code

http://www.techonthenet.com/excel/downloads/search_for_string.zip

Thanks
Rajesh

[Admin]

Hi Rajesh,

try this one.


Sub kTest()

Dim DestSheets
Dim SearchValues
Dim rngData As Range
Dim i As Long
Dim lCol As Long
Dim wksActive As Worksheet

Const HeaderRow As Long = 1
Const SearchCol As Long = 5

DestSheets = Array("Sheet2", "Sheet3", "Sheet4") 'adjust the sheet names
SearchValues = Array("Question 1", "Question 2", "Question 3") 'adjust the strings w.r. to the sheet names

Set wksActive = Worksheets("Sheet1") 'adjust the sheet name

Set rngData = wksActive.Cells(HeaderRow, 1).CurrentRegion
lCol = rngData.Columns.Count

For i = LBound(DestSheets) To UBound(DestSheets)
With rngData
.Cells(HeaderRow + 1, lCol + 2).FormulaR1C1 = "=rc[-" & lCol + 2 - SearchCol & "]=""" & SearchValues(i) & """"
.AdvancedFilter 2, .Cells(HeaderRow, lCol + 2).Resize(2), Worksheets(DestSheets(i)).Range("A1")
End With
Next

End Sub

Note: Make necessary changes in the code.

[Rajesh Kr Joshi]

Thanks a ton Admin, This is working fine.
Thanks Again :)

[Admin]

Hi Rajesh,

Thanks for the feedback. :cheers:

[Rajesh Kr Joshi]

Thanks :)