Copy filtered rows from worksheet to the last row of another worksheet - excel

Question

I've been working on adapting our excel based sales report into an in-house CRM using macros.
This is the macro I've managed to get to work using code found on this site :
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
End If
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 11
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now
End If
Next
End If
Dim a As Range
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If CBool(Len(a.Value2)) Then _
a.EntireRow.Copy _
Destination:=Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
This works great for our basic needs but whenever an opportunity closes, we'd like it to be transferred below the existing data to 3 separate worksheets based on the result of the opportunity (Won, Lost, Renewed) and removed from the main CRM sheet (aka cut and not copy). Those values being some of the choices in column 10, the same row used in my script above.
There's a myriad of different scripts around to accomplish some portion of what I want but I unfortunately couldn't get any script I've tried to work on my file, much less work as intended since our situation involves a few different "special" use case (no filters, multiple criterias, existing tables to receive data, etc).
Basically I'm looking to add on to the script above so :
all rows are still be copied to the Log sheet (Sheet 3)
when an entry matching either Won, Lost or Renewed is selected, that entire row should be cut from the CRM sheet (Sheet 1)
That row should be pasted below the existing data in either sheet 2 (won), sheet 5 (lost) and sheet 6 (renewed)
Any help or advice would be more than appreciated.
Thanks.
Edit :
I've continued to work on getting this to work and I managed to get it to work.
But when I cut the row, it also cuts away the formatting of the row including data validation. Is there any way to cut the data but leave formatting and data validation settings intact ? Perhaps trough the use of special paste ?
Here's the code I used :
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
End If
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 11
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Worksheets("CRM").Cells(xRow, xTimeColumn) = Now
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Worksheets("CRM").Cells(xRg.Row, xTimeColumn) = Now
End If
Next
End If
Dim a As Range
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If CBool(Len(a.Value2)) Then _
a.EntireRow.Copy _
Destination:=Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
End If
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Won" Then _
a.EntireRow.Cut _
Destination:=Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Sheets("CRM").Rows(10000).EntireRow.Copy
ActiveCell.EntireRow.Paste
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Lost" Then _
a.EntireRow.Cut _
Destination:=Sheet5.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Renewal" Then _
a.EntireRow.Cut _
Destination:=Sheet6.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
bm_Safe_Exit:
Application.EnableEvents = True
End Sub

Answer 1

Finally managed to it to work like I wanted.
Here's the code for anyone else this might help.
The first part inserts the date when a cell is modified.
Second part copies to data to the log page
Third part copies the data to the right tab if it meats the specified criteria and deletes the row from the CRM page.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
End If
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 11
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Worksheets("CRM").Cells(xRow, xTimeColumn) = Now
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Worksheets("CRM").Cells(xRg.Row, xTimeColumn) = Now
End If
Next
End If
Dim a As Range
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If CBool(Len(a.Value2)) Then _
a.EntireRow.Copy _
Destination:=Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
End If
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Won" Then _
a.EntireRow.Copy _
Destination:=Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Won" Then _
a.EntireRow.Delete
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Lost" Then _
a.EntireRow.Copy _
Destination:=Sheet5.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Closed Lost" Then _
a.EntireRow.Delete
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Renewal" Then _
a.EntireRow.Copy _
Destination:=Sheet6.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next a
For Each a In Intersect(Target, Columns(10), Me.UsedRange.Offset(1, 0))
If Target.Value = "Renewal" Then _
a.EntireRow.Delete
Next a
bm_Safe_Exit:
Application.EnableEvents = True
End Sub