Combine code to move rows based on cell value

[edwardl96]

Hi all,

I am trying to combine sections of code to achieve the following:

I have three worksheets: “raw data”, “completed” & “quote”.
All workbooks have the exact same layout
The header takes up row 1
Data fills column A-H. H is a status column with a drop down list, here you can select : “raw data”, “completed” & “quote”

What i am trying to achieve: On any worksheet, when the status is changed, the row is automatically sent to the corresponding worksheet.

This is what i have so far, this has been entered in the code for worksheet "raw data", part of the code will work by it’s self as below:

Sub Worksheet_Change(ByVal Target As Range)
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("raw data") 'Edit sheet name
Set sh3 = Sheets("quote") 'Edit sheet name
lr = sh1.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = sh1.Range("H2:H" & lr)
If Not Intersect(Target, rng) Is Nothing Then
    Application.EnableEvents = False
        If LCase(Target.Value) = "quote" Then
            Range("A" & Target.Row).Resize(1, 8).Copy
            sh3.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        End If
    Application.EnableEvents = True
End If
Application.CutCopyMode = False
 
End Sub

I have tried to combine multiple sections to achieve my goal ut it hasnt gone very well; this is what I have tried to do to combine the code to:

Sub MasterMacro()
Call Worksheet_Change
Call Worksheet_Change2
End Sub
Sub Worksheet_Change(ByVal Target As Range)
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("raw data") 'Edit sheet name
Set sh3 = Sheets("quote") 'Edit sheet name
lr = sh1.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = sh1.Range("H2:H" & lr)
If Not Intersect(Target, rng) Is Nothing Then
Application.EnableEvents = False
If LCase(Target.Value) = "quote" Then
Range("A" & Target.Row).Resize(1, 8).Copy
sh3.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
Range("A" & Target.Row).EntireRow.Delete
End If
Application.EnableEvents = True
End If
Application.CutCopyMode = False
End Sub

Sub Worksheet_Change2(ByVal Target As Range)
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("raw data") 'Edit sheet name
Set sh2 = Sheets("completed") 'Edit sheet name
lr = sh1.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = sh1.Range("H2:H" & lr)
If Not Intersect(Target, rng) Is Nothing Then
Application.EnableEvents = False
If LCase(Target.Value) = "completed" Then
Range("A" & Target.Row).Resize(1, 8).Copy
sh2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
Range("A" & Target.Row).EntireRow.Delete
End If
Application.EnableEvents = True
End If
Application.CutCopyMode = False
End Sub

If anyone can tell me how to combine the code so I can make the workbook do as I want I will be eternally grateful!!!

Thank you very much in advance

 

[Andrew Poulsom]

Does this work for you?

Sub Worksheet_Change(ByVal Target As Range)
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range
    Set sh1 = Sheets("raw data") 'Edit sheet name
    Set sh2 = Sheets("completed") 'Edit sheet name
    Set sh3 = Sheets("quote") 'Edit sheet name
    lr = sh1.Cells(Rows.Count, 8).End(xlUp).Row
    Set rng = sh1.Range("H2:H" & lr)
    If Not Intersect(Target, rng) Is Nothing Then
        Application.EnableEvents = False
        Range("A" & Target.Row).Resize(1, 8).Copy
        If LCase(Target.Value) = "completed" Then
            sh2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
        ElseIf LCase(Target.Value) = "quote" Then
            sh3.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
        End If
        Range("A" & Target.Row).EntireRow.Delete
        Application.EnableEvents = True
    End If
    Application.CutCopyMode = False
End Sub

 

[edwardl96]

thank you so much, that works perfectly!!!

i have copied it over to the other worksheets and made relevant alterations, they all seem to work but if i change the status for example on the "raw data" sheet to "raw data" the row of data disappears and i have no idea were it goes, could you shed some light on this??

thanks you very much

 

[Andrew Poulsom]

Sorry, I missed that possibility:

Sub Worksheet_Change(ByVal Target As Range)
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range
    Set sh1 = Sheets("raw data") 'Edit sheet name
    Set sh2 = Sheets("completed") 'Edit sheet name
    Set sh3 = Sheets("quote") 'Edit sheet name
    lr = sh1.Cells(Rows.Count, 8).End(xlUp).Row
    Set rng = sh1.Range("H2:H" & lr)
    If Not Intersect(Target, rng) Is Nothing Then
        Application.EnableEvents = False
        If LCase(Target.Value) = "completed" Then
            Range("A" & Target.Row).Resize(1, 8).Copy
            sh2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        ElseIf LCase(Target.Value) = "quote" Then
            Range("A" & Target.Row).Resize(1, 8).Copy
            sh3.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        End If
        Application.EnableEvents = True
    End If
    Application.CutCopyMode = False
End Subb

 

[edwardl96]

That seems to work perfectly!!

Thank you very much for all your help on this

 

[edwardl96]

Hello,

hope you don’t mind my asking another question on this! i have expanded my spreadsheet a bit and made a few changes. Would you be able to help me adapt the code to work on this???

There is data on rows A-W. W is now the status tab.
The header takes up the top 3 rows. All entries are on Row 4 and below
All sheets are the same

[Sub Worksheet_Change(ByVal Target As Range)
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range
    Set sh2 = Sheets("Profiling") 'Edit sheet name
    Set sh4 = Sheets("Raw Leads") 'Edit sheet name
    Set sh5 = Sheets("Prospects") 'Edit sheet name
    Set sh6 = Sheets("quoted") 'Edit sheet name
    Set sh7 = Sheets("Recycled") 'Edit sheet name
    Set sh8 = Sheets("Rejected") 'Edit sheet name
    lr = sh2.Cells(Rows.Count, 23).End(xlUp).Row
    Set rng = sh2.Range("W4:W" & lr)
    If Not Intersect(Target, rng) Is Nothing Then
        Application.EnableEvents = False
        If LCase(Target.Value) = "Raw Leads" Then
            Range("A" & Target.Row).Resize(1, 23).Copy
            sh4.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        ElseIf LCase(Target.Value) = "Prospects" Then
            Range("A" & Target.Row).Resize(1, 23).Copy
            sh5.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        ElseIf LCase(Target.Value) = "Quoted" Then
            Range("A" & Target.Row).Resize(1, 23).Copy
            sh6.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        ElseIf LCase(Target.Value) = "Recyled" Then
            Range("A" & Target.Row).Resize(1, 23).Copy
            sh7.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        ElseIf LCase(Target.Value) = "Rejected" Then
            Range("A" & Target.Row).Resize(1, 23).Copy
            sh8.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
            Range("A" & Target.Row).EntireRow.Delete
        End If
        Application.EnableEvents = True
    End If
    Application.CutCopyMode = False
End Sub

thank you very much!

 

[Andrew Poulsom]

What do you need help with exactly?

 

[edwardl96]

Hi, thanks for coming back to me. The code I gave and have adapted doesn't work. I'm not sure why that is though. This is were I was hoping you could help?
Thanks.

 

[Andrew Poulsom]

In what way doesn't it work?

 

[edwardl96]

Hi,
When I put the value in column W nothing happens. I wasn't sure if the code looked correct or not, if you think it looks OK I will keep trying to make it work.
Thanks!