Vba Cut Paste By Criteria

[Emoncada]

I have 3 sheets in a workbook.
I want to be able to look at sheet("Updater").


If Left(Range("C"), 2 = "HP" Then

I want to copy and paste data from that row to sheet("DM")

I would need to find next available row in sheet("DM")


Then Paste Values from that row to different columns in Sheet("Updater")

Sheet("Updater") column "B" to Sheet("DM") column "E"
Sheet("Updater") column "C" to Sheet("DM") column "A"
Sheet("Updater") column "E" to Sheet("DM") column "C"
Sheet("Updater") column "J" to Sheet("DM") column "H"
etc.....

Else If Left(Range("C"), 2 <> "HP" Then

Same setup except paste it to Sheet("SJ")

After all rows in Sheet("Updater") have been checked then delete all rows.

Any Assistance would be great.

[Emoncada]

ok I got the following.


Sub Copy_Over()
Dim dm As Long, sj As Long, r As Long
Dim us As Long
dm = Sheets("DM").Cells(Rows.Count, "A").End(xlUp).Row
sj = Sheets("SJ").Cells(Rows.Count, "A").End(xlUp).Row
us = Sheets("Updater").Cells(Rows.Count, "A").End(xlUp).Row
For r = us To 2 Step -1
If Left(Range("C" & r).Value, 2) = "HP" Then

Rows(r).Cut Destination:=Sheets("DM").Range("A" & dm + 1)
dm = Sheets("DM").Cells(Rows.Count, "A").End(xlUp).Row
End If

If Left(Range("C" & r).Value, 2) <> "HP" Then
Rows(r).Cut Destination:=Sheets("SJ").Range("A" & sj + 1)
sj = Sheets("SJ").Cells(Rows.Count, "A").End(xlUp).Row
End If

Range("A1").Select

Next r
End Sub



Now this works but I need to replace

Rows(r).Cut Destination:=Sheets("DM").Range("A" & dm + 1)
dm = Sheets("DM").Cells(Rows.Count, "A").End(xlUp).Row

I need to have to copy column data from r like below.

Sheet("Updater") column "B" to Sheet("DM") column "E"
Sheet("Updater") column "C" to Sheet("DM") column "A"
Sheet("Updater") column "E" to Sheet("DM") column "C"
Sheet("Updater") column "J" to Sheet("DM") column "H"

[mancubus]

delete all cells from row 2?




Sub copy_based_on_crit_v1()
Dim i As Long, LastRow As Long, LR As Long

With Worksheets("Updater")
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
For i = 2 To LastRow
If Left(.Range("C" & i), 2) = "HP" Then
LR = Worksheets("DM").Cells.Find("*", , , , xlByRows, xlPrevious).Row
Worksheets("DM").Range("E" & LR + 1) = .Range("B" & i)
Worksheets("DM").Range("A" & LR + 1) = .Range("C" & i)
Worksheets("DM").Range("C" & LR + 1) = .Range("E" & i)
Worksheets("DM").Range("H" & LR + 1) = .Range("J" & i)
Else
LR = Worksheets("SJ").Cells.Find("*", , , , xlByRows, xlPrevious).Row
Worksheets("SJ").Range("E" & LR + 1) = .Range("B" & i)
Worksheets("SJ").Range("A" & LR + 1) = .Range("C" & i)
Worksheets("SJ").Range("C" & LR + 1) = .Range("E" & i)
Worksheets("SJ").Range("H" & LR + 1) = .Range("J" & i)
End If
Next
UsedRange.Offset(1).ClearContents
End With
End Sub

[mancubus]

clear only copied cells?


Sub copy_based_on_crit_v2()
Dim i As Long, LastRow As Long, LR As Long

With Worksheets("Updater")
LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
For i = 2 To LastRow
If Left(.Range("C" & i), 2) = "HP" Then
LR = Worksheets("DM").Cells.Find("*", , , , xlByRows, xlPrevious).Row
Worksheets("DM").Range("E" & LR + 1) = .Range("B" & i)
Worksheets("DM").Range("A" & LR + 1) = .Range("C" & i)
Worksheets("DM").Range("C" & LR + 1) = .Range("E" & i)
Worksheets("DM").Range("H" & LR + 1) = .Range("J" & i)
Union(.Range("B" & i), .Range("C" & i), .Range("E" & i), .Range("J" & i)).ClearContents
Else
LR = Worksheets("SJ").Cells.Find("*", , , , xlByRows, xlPrevious).Row
Worksheets("SJ").Range("E" & LR + 1) = .Range("B" & i)
Worksheets("SJ").Range("A" & LR + 1) = .Range("C" & i)
Worksheets("SJ").Range("C" & LR + 1) = .Range("E" & i)
Worksheets("SJ").Range("H" & LR + 1) = .Range("J" & i)
Union(.Range("B" & i), .Range("C" & i), .Range("E" & i), .Range("J" & i)).ClearContents
End If
Next
End With
End Sub

[Emoncada]

I would need to clearcontents, but not include row 1 (Header Row)

[mancubus]

i modified the procedure in post #3

[Emoncada]

I'm getting Run-time Error '424' Object required


UsedRange.Offset(1).ClearContents

[mancubus]

Sorry. Add a . before UsedRange.

[Emoncada]

Perfect Thanks mancubus

[mancubus]

you are welcome. thanks for the feedback.