Change Event Code

Skybluekid

Well-known Member
Joined
Apr 17, 2012
Messages
1,224
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I am very stumped at the moment. I am using the below code to copy cells if the Sales person selects an option:

Code:
Private Sub Worksheet_Change(ByVal Target As Range)


            Dim R As Range
            Dim s As String
            Dim Rng(1 To 8)
            Dim NV As String
            Dim OV As String
            Dim FV As String
            Dim Rng2 As Range
            Dim Cell As Range
            Dim Old
            


'Execute code if value in twentieth column is changed
If Target.Column = 20 Then


        'If value in T column of the row is "Won" then copy the row to destination sheet
            If Target.Value = "Won" Then


            Rng(1) = "A" & Target.Row
            Rng(2) = "B" & Target.Row
            Rng(3) = "C" & Target.Row
            Rng(4) = "E" & Target.Row
            Rng(5) = "G" & Target.Row
            Rng(6) = "K" & Target.Row
            Rng(7) = "L" & Target.Row
            Rng(8) = "M" & Target.Row


            s = Join(Rng, ",")


            Set R = Range(s)


            R.Copy Destination:=Sheets("Won Business").Range("A" & Rows.Count).End(xlUp).Offset(1)
        
            End If
            
            'If value in T column of the row is "Lost" then copy the row to destination sheet
            If Target.Value = "Lost" Then


            Rng(1) = "A" & Target.Row
            Rng(2) = "B" & Target.Row
            Rng(3) = "C" & Target.Row
            Rng(4) = "E" & Target.Row
            Rng(5) = "G" & Target.Row
            Rng(6) = "K" & Target.Row
            Rng(7) = "L" & Target.Row
            Rng(8) = "M" & Target.Row


            s = Join(Rng, ",")


            Set R = Range(s)


            R.Copy Destination:=Sheets("Lost Business").Range("A" & Rows.Count).End(xlUp).Offset(1)
            
            End If
                 
            'If value in T column of the row is "Hot" then copy the row to destination sheet
            If Target.Value = "Hot" Then
                 
            Rng(1) = "A" & Target.Row
            Rng(2) = "B" & Target.Row
            Rng(3) = "C" & Target.Row
            Rng(4) = "E" & Target.Row
            Rng(5) = "G" & Target.Row
            Rng(6) = "K" & Target.Row
            Rng(7) = "L" & Target.Row
            Rng(8) = "M" & Target.Row


            s = Join(Rng, ",")


            Set R = Range(s)


            R.Copy Destination:=Sheets("Hot Deals").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    
            End If
End If


End Sub


This works well, but I have a twist. If the Sales has chosen Hot originally, then changes the value to Won (or Lost), I will need it find the deal on the Hot Deals Sheet, delete that row. It should also then copy the cells to the Won (or Lost, as the case maybe) Sheet.

I have looked at various options but none seem to work.

Thank you in Advance as any help would be very appreciated.
 
Last edited by a moderator:

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
1.below is your code amended to avoid duplicating many lines (ignore if you wish)

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim r As Range, s As String, Rng(1 To 8)
Dim sName As Worksheet, x As Long

'Execute code if value in twentieth column is changed
If Target.Column = 20 Then
        x = Target.Row
        Rng(1) = "A" & x
        Rng(2) = "B" & x
        Rng(3) = "C" & x
        Rng(4) = "E" & x
        Rng(5) = "G" & x
        Rng(6) = "K" & x
        Rng(7) = "L" & x
        Rng(8) = "M" & x
        s = Join(Rng, ",")
        Set r = Range(s)
'sheet name is based on target value
    Select Case LCase(Target.Value)
        Case "won":     Set sName = Sheets("Won Business")
        Case "lost":    Set sName = Sheets("Lost Business")
        Case "hot":     Set sName = Sheets("Hot Deals")
    End Select
'copy and paste
         r.Copy Destination:=sName.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If

End Sub

2. Your Question...
Sheet X (=the sheet containing the value to be removed) can be determined when the user selects cell in column 20
Sheet Y (=the new sheet) can be determined when the user amends the value

But VBA needs to know which row on SheetX to delete
a) Are any of the 8 values copied across totally unique ? If so which one (A,B,C,E,G,K,L or M) ?
b) Otherwise the 8 values could be concatented and the row which returns the first match deleted
Obviously (a) and (b) are viable solutions only if users are not in the habit of amending values AFTER the values have been copied across

Let me know what might work
thanks
 
Last edited:
Upvote 0
Thank you for the code.

In the copied cells there is a Reference, for example, DW1123, this is unique to that row.

I have tried the below, but it does not work :(

Code:
For Each Cell In Target


    If Not (Intersect(Cell, Target.Column) Is Nothing) Then
        NV = Cell.Value
        OV = Old
        
            If OV = "Hot" And NV = "Won" Then
            
                FV = Range("E" & Target.Row).Value
            
                Set Rng2 = Sheets("Hot Deals").Range("D" & Rows.Count).End(xlUp).Find(FV)
                
                If Rng2 = "" Then
            
                    MsgBox "No Value was found on Hot Deals Sheet"
                
                    Else
                
                    Sheets("Hot Deals").Rng2.Rows.Delete
                
                End If
                
            End If


    End If
    
Next Cell



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Old = Target.Value
End Sub
 
Last edited by a moderator:
Upvote 0
In the copied cells there is a Reference, for example, DW1123, this is unique to that row
- in which column is that reference in the original sheet?
- in which column is that reference in the (Won/Lost Hot) sheet?
 
Last edited:
Upvote 0
Try something like this (goes in sheet module)
- triggers when user selects cell in column 20 where cell already contains a value

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim uniq As String, sName As Worksheet, foundCell As Range
If Target.CountLarge > 1 Then Exit Sub

If Target.Column = 20 Then
        If Target = "" Then Exit Sub
        If Not MsgBox("Do you want to change selected value", vbYesNo) = vbYes Then
            Target.Offset(, 1).Select
        Else
          [COLOR=#006400][I]  'what is VBA looking for (column E value)[/I][/COLOR]
            uniq = Range("E" & Target.Row)
[I][COLOR=#006400]            'which sheet?[/COLOR][/I]
            Select Case LCase(Target.Value)
                Case "won":     Set sName = Sheets("Won Business")
                Case "lost":    Set sName = Sheets("Lost Business")
                Case "hot":     Set sName = Sheets("Hot Deals")
            End Select
       [I][COLOR=#006400] 'find the value in column D of the other sheet[/COLOR][/I]
            On Error Resume Next    'require this in case it is not in the sheet
            Set foundCell = sName.Range("D:D").Find(What:=uniq, LookIn:=xlValues, LookAt:=xlWhole)
            If Not foundCell Is Nothing Then
       [I][COLOR=#006400] 'delete the row[/COLOR][/I]
                foundCell.EntireRow.Delete
                Application.EnableEvents = [COLOR=#ff0000]False [/COLOR]   [COLOR=#006400]'prevents Worksheet_Change from being trigerred temporarily[/COLOR]
                    Target.ClearContents
                Application.EnableEvents = [COLOR=#ff0000]True[/COLOR]
            Else
                MsgBox "Reference " & uniq & " not found in " & sName.Name
            End If
            On Error GoTo 0
        End If
End If
End Sub


You also need this lne in Worksheet_Change in case anyone deletes the value - prevents code from failing
(or use Data Validation to prevent value being deleted and force one of the valid options to be selected)
Code:
If Target.Column = 20 Then
[COLOR=#ff0000]    If Target.Value = "" Then Exit Sub[/COLOR]
 
Last edited:
Upvote 0
Thank you very much. This has help my understanding as well
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,142
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top