[SOLVED] Macro to cut rows into another worksheet if a cell contains a specific word

[Jason via OfficeKB.com]

Ive got a spreadsheet which contains outstanding share trades which clients
have placed, but it contains other products i do not deal with. I would
like the macro to run throught the asset name column and to cut the entire
row into another worksheet called delete if it contains either of the
following: SWAPS, FX, CFD,Bank Bill,pension or SUPER. Would this code be
straight forward to write? anyone with suggestions?

[Patrick Molloy]

Sub Remover()
Dim newrow As Long
Dim rw As Long
Dim product As String
product = "A"
rw = 1
Do Until Cells(rw, product) = ""
Select Case Cells(rw, product)
Case "SWAPS", "FX", "CFD", "Bank Bill", "pension", "SUPER"
newrow = newrow + 1
Worksheets("delete").Rows(newrow).Value = Rows(rw).Value
Case Else
End Select
rw = rw + 1
Loop
End Sub

"Jason via OfficeKB.com" wrote:

> Ive got a spreadsheet which contains outstanding share trades which clients
> have placed, but it contains other products i do not deal with. I would
> like the macro to run throught the asset name column and to cut the entire
> row into another worksheet called delete if it contains either of the
> following: SWAPS, FX, CFD,Bank Bill,pension or SUPER. Would this code be
> straight forward to write? anyone with suggestions?
>

[Tom Ogilvy]

Assume assests column is F:

Sub CutData()
Dim sStr as String, Cell as Range, rng as Range
sStr = "#SWAPS#FX#CFD#Bank Bill#Pension#SUPER#"
for each cell in Range("F2:F200")
if Instr(1,sStr,Cell.Value,vbTextCompare)>0 then
if rng is nothing then
set rng = cell
else
set rng = union(rng,cell)
end if
end if
Next
if not rng is nothing then
rng.EntireRow.copy Destination:=worksheets( _
"OtherSheet").Range("A1")
rng.EntireRow.Delete
End if
End Sub

--
Regrds,
Tom Ogilvy

"Jason via OfficeKB.com" <forum@nospam.OfficeKB.com> wrote in message
news:d12901942750477ea0d6eec6b7a10098@OfficeKB.com...
> Ive got a spreadsheet which contains outstanding share trades which
clients
> have placed, but it contains other products i do not deal with. I would
> like the macro to run throught the asset name column and to cut the entire
> row into another worksheet called delete if it contains either of the
> following: SWAPS, FX, CFD,Bank Bill,pension or SUPER. Would this code be
> straight forward to write? anyone with suggestions?

[HotRod]

Try something like this You will need to change the variables below to match
tour rows and sheet names etc.


Public Sub CleanUp_My_Data()

Dim Rng As Range 'number of rows
Dim First_Row As Integer 'FIRST ROW Number
Dim SheetName As String 'Name of working SHEET
Dim Paste_Sheet As String 'Name of sheet to Paste to
Dim Column_To_Check As String 'Letter of the asset name column
Dim Paste_Row As Integer
Dim lngROW As Long 'row count


'ADJUST THESE VALUES BELOW

First_Row = 5
SheetName = "Sheet1"
Paste_Sheet = "delete"
Column_To_Check = "B" 'What is the AssetName Column
Paste_Row = 1

'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
Set Rng = Worksheets(SheetName).UsedRange.Rows
lngROW = First_Row


While lngROW <= Rng.Rows.Count


If InStr(1, UCase(Worksheets(SheetName).Range("F" & lngROW).Value),
"SWAPS") > 0 Or _
InStr(1, UCase(Worksheets(SheetName).Range("F" & lngROW).Value),
"FX") > 0 Or _
InStr(1, UCase(Worksheets(SheetName).Range("F" & lngROW).Value),
"CFD") > 0 Or _
InStr(1, UCase(Worksheets(SheetName).Range("F" & lngROW).Value),
"BANK BILL") > 0 Or _
InStr(1, UCase(Worksheets(SheetName).Range("F" & lngROW).Value),
"PENSION") > 0 Or _
InStr(1, UCase(Worksheets(SheetName).Range("F" & lngROW).Value),
"SUPER") > 0 Then

Application.Range("A" & lngROW, "ZZ" & lngROW).Copy
Destination:=Worksheets(Paste_Sheet).Range("A" & Paste_Row)

lngROW = lngROW + 1
Paste_Row = Paste_Row + 1
End If


DoEvents
Wend

[Jason via OfficeKB.com]

Thanks guys for your input ! ill give it a crack when I go to work on
monday. Enjoy your weekend !

Jason

--
Message posted via http://www.officekb.com