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

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.

Code:

---

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/do...for_string.zip

Thanks
Rajesh

Hi Rajesh,

try this one.

Code:

---

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.

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

Hi Rajesh,

Thanks for the feedback. :cheers:

Thanks :)