macro to find data and filter it and copy to another worksheet

[kay]

I have a worksheet which has many columns,
what i would like to do that under "Description" column i have such statements
"Suggest resource for "SAP Services Engineer" position on project"
Suggest resource for "Oracle Services Engineer" position on project
So i want to create a macro which will look for "SAP" word in "Description"
column and then filter those rows and copy those rows to other sheet.

Thanks!

 

[sebastienm]

Hi,
Say your data is in sheet sheet1 and Description is in column B.
And you want to copy the result in Sheet2 at the end of the cells already
used (by checking first column).
Note: if you want cells exactly equal to "SAP", search for "SAP", otherwise,
for
cells containing SAP, search for "*SAP*" (using the wildcard *)
Copy the code below in a module and run the sub Test.

Sub test()
FindCopyRows "*SAP*",sheet1.Range("B:b"),sheet2.Columns(1)
FindCopyRows "*oracle*",sheet1.Range("B:b"),sheet2.Columns(1)
ENd sub

''' ###########################################

''' find values FindWhat in a Where range and copy (not cut) their rows in
''' in column of ToRange
Sub FindCopyRows(FindWhat As Variant, Where As Range, ToRange As Range)
Dim rgResult As Range
Dim copyTo As Range

Set rgResult = FindAll(FindWhat, Where)
If Not rgResult Is Nothing Then
''' find first blank row in destination
Set copyTo = ToRange.Cells(1).EntireColumn
Set copyTo = copyTo.Cells(copyTo.Cells.Count)
Set copyTo = copyTo.End(xlUp).Offset(1, 0)
''' copy rows there
rgResult.EntireRow.Copy copyTo.EntireRow
End If
End Sub


''' ################################################
''' ######## Reusable/supporting code
''' ################################################

''' Find all cells matching a criteria in a range
Public Function FindAll(FindWhat As Variant, Where As Range)
Dim rgResult As Range
Dim firstAddress As String
Dim cell As Range

With Where
''' find first result cell
Set cell = .Find(what:=FindWhat, LookIn:=xlValues, Lookat:=xlWhole,
MatchCase:=False)
''' find other result cells
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
''' add found cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next cell
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End If
End With
Set FindAll = rgResult
End Function
'##############################################