VBA for searching string in a column and copy rows depending on string in adjacent cell

I am completely new for VBA. I have excel data sheet containing numbers and strings. I want to search for certain string say 'CYP' in column 'I' then look for a cell of its row at column 'C' and copy entire rows containing the string of cell 'C'. I want to paste in sheet 2 of the same workbook and loop it again to look for remaining CYPs in column 'I'. (I have attached a problem file sample with desired result in the attachment.)

Would you help me on this please?

Hi xprakash,

Welcome the forum!!

Let us know how this goes:

Option Explicit
Sub Macro1()

    'Written by Trebor76
    'Visit my website www.excelguru.net.au
    
    'Copy an entire row from Sheet1 to Sheet2 if the text 'CYP' (case sensitive) exists in Col. I of Sheet1
    
    'http://www.excelforum.com/excel-programming-vba-macros/962511-vba-for-searching-string-in-a-column-and-copy-rows-depending-on-string-in-adjacent-cell.html

    Dim rngCell As Range
    
    Application.ScreenUpdating = False
    
    For Each rngCell In Sheets("Sheet1").Range("I1:I" & Sheets("Sheet1").Range("I" & Rows.Count).End(xlUp).Row)
        If InStr(rngCell, "CYP") > 0 Then
            Rows(rngCell.Row).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
        End If
    Next rngCell
    
    Application.ScreenUpdating = True
    
    MsgBox "All applicable rows have been copied.", vbInformation, "Excel Guru"

End Sub

Regards,

Robert

So the first matching row in Sheet1 is 2. Do you then want all the matching entries for ADF45 (this is in cell C2) copied to Sheet2. If so, what happens with Row 3 as the code in cell C3 is again ADF45? This will mean that all the cells with ADF45 will in fact be copied 4 times as there's an overall total of 4 matches?

Perhaps if you could post the desired results in a separate tab it will make things clearer.

Robert

You didn't answer the second question i.e. what happens when the same title is found in column C

In any case, I think you only want show the title from column C once, so see how this goes:

Option Explicit
Sub Macro1()

    'Written by Trebor76
    'Visit my website www.excelguru.net.au
    
    'Copy an entire row from Sheet1 to Sheet2 for each unique matching item in Col. C if the text in Col. I contains the text 'CYP' (case sensitive)
    
    'http://www.excelforum.com/excel-programming-vba-macros/962511-vba-for-searching-string-in-a-column-and-copy-rows-depending-on-string-in-adjacent-cell.html

    Dim rngCell As Range
    Dim objMyUniqueArray As Object
    Dim lngMyArrayCounter As Long
    Dim lngMyRow As Long
    Dim varMyItem As Variant
    
    Application.ScreenUpdating = False
    
    Set objMyUniqueArray = CreateObject("Scripting.Dictionary")
    
    For Each rngCell In Sheets("Sheet1").Range("I1:I" & Sheets("Sheet1").Range("I" & Rows.Count).End(xlUp).Row)
        If InStr(rngCell, "CYP") > 0 Then
            If Not objMyUniqueArray.Exists(Trim(Cells(rngCell.Row, "C"))) Then
                lngMyArrayCounter = lngMyArrayCounter + 1
                objMyUniqueArray.Add (Trim(Cells(rngCell.Row, "C"))), lngMyArrayCounter
                varMyItem = Sheets("Sheet1").Cells(rngCell.Row, "C")
                For lngMyRow = 1 To Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
                    If Sheets("Sheet1").Cells(lngMyRow, "C") = varMyItem Then
                        Rows(rngCell.Row).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
                    End If
                Next lngMyRow
            End If
        End If
    Next rngCell
    
    Set objMyUniqueArray = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "All applicable rows have been copied.", vbInformation, "Excel Guru"

End Sub

Robert

Thank you again Robert. But this macro copied the first row with CYP at column 'I for every row with same string at a cell in column C of same row. Would you modify it testing with the file attached above please?

Yes, by changing this line of code...

Rows(rngCell.Row).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)

...to this:

Rows(lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)

should do the job.

Regards,

Robert

That's great

If you could please mark the thread as solved it would be appreciated.

Regards,

Robert