CODEWITHSUNDEEP
vbaexcel
Prakshbabu
Prakshbabu

Reputation: 11

VBA for searching string in a column and copy entire rows depending on the presence of certain string at 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.

Would you help me on this please?

After the suggestion from pnuts, here is my macro code

Sub Macro1()
'
' Macro1 Macro
'

'
    Columns("I:I").Select
    Range("I729").Activate
    Selection.Find(What:="cyp", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveWindow.SmallScroll Down:=5
    Range("C749").Select
    Selection.Copy
    Columns("C:C").Select
    Range("C734").Activate
    Selection.Find(What:="EPT001TT0601C000151", After:=ActiveCell, LookIn:= _
        xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
        , MatchCase:=False, SearchFormat:=False).Activate
    Rows("746:750").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Paste
End Sub

In this code the CYP was found in I749, cell C749 was copied as string and first row in column C containing the same string was searched followed by copying of the entire row and 4 more followed by it then pasting in sheet2 of the same workbook. What I wanted was to loop this action again and again upto the end of column I and repeat the same action.

Thank you!

Upvotes: 1

Views: 15681

Answers (1)

Prakshbabu
Prakshbabu

Reputation: 11

I managed to solve the problem with the help of Trebor76 at Excelforum. Here I am giving solution in that way it might be helpful for some newbies like myself with similar problem.

Option Explicit
Sub Macro1()

    'Written and assisted by Trebor76

    '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(lngMyRow).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

End Sub

Cheers!

Upvotes: 0

Related Questions