View Full Version : [SOLVED:] Vba Cut Paste By Criteria
Emoncada
06-10-2014, 06:04 AM
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
06-10-2014, 07:11 AM
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
06-10-2014, 07:14 AM
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
06-10-2014, 07:30 AM
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
06-10-2014, 07:35 AM
I would need to clearcontents, but not include row 1 (Header Row)
mancubus
06-10-2014, 08:08 AM
i modified the procedure in post #3
Emoncada
06-10-2014, 08:19 AM
I'm getting Run-time Error '424' Object required
UsedRange.Offset(1).ClearContents
mancubus
06-10-2014, 08:28 AM
Sorry. Add a . before UsedRange.
Emoncada
06-10-2014, 08:50 AM
Perfect Thanks mancubus
mancubus
06-10-2014, 02:05 PM
you are welcome. thanks for the feedback.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.