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]

Where did you put the VBA code? In the module for Worksheet "Profiling"?