Macro - Copy row base on criteria

[ck13]

Hi,

I have this database from column C to T and row 4 onwards. What I hope to
achieve is to copy the entire row from C to T to another sheet (similarly
from Column C to T and row 4 onwards) if the cell for that row in Column L is
"Lost Case". At the same time, the selected rows to be copied in the original
sheet should be deleted after being copied.

Another consideration is that new data will be added to the original sheet
from time to time and thus the database might expand or shrink (after being
copied and delete, and the addition or new data). Thus, when the macro is run
and if new 'Lost Case' is found, the new rows should be added to the 2nd
spreadsheet rather than replace old data in spreadsheet 2. Thus it is an
expanding list.

I hope that I am clear with it.

I have thought of using filter, copy and paste but feel that with a macro,
it will be less work for all the users. Any comments on this? Filter or macro?

 

[Jacob Skaria]

Try the below...Edit the sheetnames

Sub CopyRowstoDiffSheet()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim lngRow As Long, lngTargetRow As Long

Set ws1 = Sheets("SourceSheetName")
Set ws2 = Sheets("TargetSheetName")

For lngRow = ws1.Cells(Rows.Count, "L").End(xlUp).Row To 4 Step -1
If ws1.Range("L" & lngRow) = "Lost Case" Then
lngTargetRow = WorksheetFunction.Max(4, _
ws2.Cells(Rows.Count, "L").End(xlUp).Row + 1)
ws1.Range("C" & lngRow & ":T" & lngRow).Copy _
ws2.Range("C" & lngTargetRow)
ws1.Rows(lngRow).Delete
End If
Next

End Sub

 

[ck13]

Hi Jacob,

It works brillantly. Thanks for your help. I need to trouble you again on 2
issue regarding the code as I am not familiar on macro (basically I try and
error).

Firstly, as there are formulas and condition format in both the source and
target sheet, I would like to copy only the values. I amend your code after
searching on the online forum. Can you help me to see if the changes I made
is correct? I tried it out and looks fine, just that I need to be sure that
it fits in with your code.

Sub CopyRowstoDiffSheet()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim lngRow As Long, lngTargetRow As Long

Set ws1 = Sheets("Pipeline (new customers)")
Set ws2 = Sheets("Lost Case")

For lngRow = ws1.Cells(Rows.Count, "L").End(xlUp).Row To 4 Step -1
If ws1.Range("L" & lngRow) = "Lost Case" Then
lngTargetRow = WorksheetFunction.Max(4, _
ws2.Cells(Rows.Count, "L").End(xlUp).Row + 1)
ws1.Range("C" & lngRow & ":T" & lngRow).Copy
ws2.Range("C" & lngTargetRow).PasteSpecial Paste:=xlPasteValues
ws1.Rows(lngRow).Delete
End If
Next

End Sub


Secondly is that I have another copy function but the range are different.
Similarly, I have amend it and will appreciate if you can guide me if it is
correct or there is a way where you can make it better.

Sub CopyRowstoDiffSheet2()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim lngRow As Long, lngTargetRow As Long

Set ws1 = Sheets("Pipeline (new customers)")
Set ws2 = Sheets("Current customers")

For lngRow = ws1.Cells(Rows.Count, "L").End(xlUp).Row To 4 Step -1
If ws1.Range("L" & lngRow) = "100% - Case Won" Then
lngTargetRow = WorksheetFunction.Max(4, _
ws2.Cells(Rows.Count, "C").End(xlUp).Row + 1)
ws1.Range("D" & lngRow & ":H" & lngRow).Copy
ws2.Range("C" & lngTargetRow).PasteSpecial Paste:=xlPasteValues
ws1.Range("J" & lngRow & ":J" & lngRow).Copy
ws2.Range("K" & lngTargetRow).PasteSpecial Paste:=xlPasteValues
ws1.Range("O" & lngRow & ":R" & lngRow).Copy
ws2.Range("L" & lngTargetRow).PasteSpecial Paste:=xlPasteValues
ws1.Range("N" & lngRow & ":N" & lngRow).Copy
ws2.Range("I" & lngTargetRow).PasteSpecial Paste:=xlPasteValues
ws1.Rows(lngRow).Delete
End If
Next

End Sub

 

[Jacob Skaria]

Yes..Disable the screen updating...

Application.ScreenUpdating = False
For lngRow = ws1.Cells(Rows.Count, "L").End(xlUp).Row To 4 Step -1
If ws1.Range("L" & lngRow) = "Lost Case" Then
lngTargetRow = WorksheetFunction.Max(4, _
ws2.Cells(Rows.Count, "L").End(xlUp).Row + 1)
ws1.Range("C" & lngRow & ":T" & lngRow).Copy
ws2.Range("C" & lngTargetRow).PasteSpecial Paste:=xlPasteValues
ws1.Rows(lngRow).Delete
End If
Next
Application.ScreenUpdating = True