Combining VBA Codes

[rhmkrmi]

Hi there,

I have difficulty combining this code:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim isect As Range
    Dim cell As Range
   
    Set isect = Intersect(Target, Range("N:N"))
   
'   Exit sub if value in column N is not updated
    If isect Is Nothing Then Exit Sub
   
'   Loop through cells just updated in column N
    For Each cell In isect
        If (cell = "Yes") And (cell.Offset(0, -6) = "CONTRACT") Then
            MsgBox "Entry in row " & cell.Row & " requires review!", vbOKOnly, "ALERT!!!"
        End If
    Next cell

End Sub

into this one:

Private Sub Worksheet_Change(ByVal Target As Range)

'   ***BLOCK1***
    Dim sUndoList As String

    On Error Resume Next

    If Not Intersect(Target, Range("A1:Z100")) Is Nothing Then
        sUndoList = CommandBars.FindControl(ID:=128).List(1)
        If Left(sUndoList, 5) = "Paste" Or sUndoList = "Auto Fill" Or sUndoList = "Drag and Drop" Then
            Application.EnableEvents = False
            Application.Undo
            Application.OnUndo "", ""
            Application.EnableEvents = True
        End If
    End If
   

'   ***BLOCK2***
    Dim rng As Range
    Dim cell As Range
    Dim rw As Long

'   See if any cells updated in column B
    Set rng = Intersect(Target, Range("B:B"))
    If rng Is Nothing Then Exit Sub

    Application.EnableEvents = False

'   Loop through updated cells in column B
    For Each cell In rng
        rw = cell.Row
        Select Case cell.Value
            Case "Home"
                Range(Cells(rw, "F"), Cells(rw, "V")) = "Check"
                Range(Cells(rw, "E"), Cells(rw, "E")) = ""
                Range(Cells(rw, "F"), Cells(rw, "V")).Interior.Color = 15132390
                Range(Cells(rw, "E"), Cells(rw, "E")).Interior.Pattern = xlNone
            Case "School"
                Cells(rw, "E") = "Check"
                Range(Cells(rw, "F"), Cells(rw, "V")) = ""
                Cells(rw, "E").Interior.Color = 15132390
                Range(Cells(rw, "F"), Cells(rw, "V")).Interior.Pattern = xlNone
            Case Else
                Range(Cells(rw, "E"), Cells(rw, "V")) = ""
                Range(Cells(rw, "E"), Cells(rw, "V")).Interior.Pattern = xlNone
        End Select
    Next cell
   
    Application.EnableEvents = True

End Sub

Could you please help?

When I comment out Private Sub Worksheet_Change(ByVal Target As Range) and Dim isect As Range and Dim cell As Range I do not get the compile error message but then nothing works!

Also, can you please help me replace And (cell.Offset(0, -6) = "CONTRACT") with a code that checks if the right eight letters are "CONTRACT"?

Thanks.

 

[DanteAmor]

keep popping up the message and not let exit cell if conditions are met

For that it is necessary to add the Selection event, try this:

Dim MyCell As Range, stat As Boolean    'to the top of the code

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim cell As Range
  Dim rw As Long
  
'***BLOCK1***
  Dim sUndoList As String
  On Error Resume Next
  If Not Intersect(Target, Range("A1:Z100")) Is Nothing Then
    sUndoList = CommandBars.FindControl(ID:=128).List(1)
    If Left(sUndoList, 5) = "Paste" Or sUndoList = "Auto Fill" Or sUndoList = "Drag and Drop" Then
      Application.EnableEvents = False
      Application.Undo
      Application.OnUndo "", ""
      Application.EnableEvents = True
    End If
  End If
  On Error GoTo 0
  
'*** Loop through cells just updated in column N ***
  If Not Intersect(Target, Range("H:H, N:N")) Is Nothing Then
    Set MyCell = Nothing
    stat = False
    For Each cell In Target
      If UCase(Right(Range("H" & cell.Row).Value, 8)) = "CONTRACT" And _
         UCase(Range("N" & cell.Row)) = UCase("Yes") Then
        MsgBox "Entry in row " & cell.Row & " requires review!", vbOKOnly, "ALERT!!!"
        Application.EnableEvents = False
        cell.Select
        Set MyCell = cell
        stat = True
        Application.EnableEvents = True
      End If
    Next cell
  End If

'***BLOCK2*** Loop through updated cells in column B
  If Not Intersect(Target, Range("B:B")) Is Nothing Then
    Application.EnableEvents = False
    For Each cell In Target
      rw = cell.Row
      Select Case cell.Value
        Case "Home"
          Range(Cells(rw, "F"), Cells(rw, "V")) = "Check"
          Range(Cells(rw, "E"), Cells(rw, "E")) = ""
          Range(Cells(rw, "F"), Cells(rw, "V")).Interior.Color = 15132390
          Range(Cells(rw, "E"), Cells(rw, "E")).Interior.Pattern = xlNone
        Case "School"
          Cells(rw, "E") = "Check"
          Range(Cells(rw, "F"), Cells(rw, "V")) = ""
          Cells(rw, "E").Interior.Color = 15132390
          Range(Cells(rw, "F"), Cells(rw, "V")).Interior.Pattern = xlNone
        Case Else
          Range(Cells(rw, "E"), Cells(rw, "V")) = ""
          Range(Cells(rw, "E"), Cells(rw, "V")).Interior.Pattern = xlNone
      End Select
    Next cell
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not MyCell Is Nothing Then
    If UCase(Right(Range("H" & MyCell.Row).Value, 8)) = "CONTRACT" And _
       UCase(Range("N" & MyCell.Row)) = UCase("Yes") Then
      If stat = True Then
        stat = False
        Exit Sub
      End If
      MsgBox "Entry in row " & MyCell.Row & " requires review!", vbOKOnly, "ALERT!!!"
      Application.EnableEvents = False
      MyCell.Select
      Application.EnableEvents = True
    End If
  End If
End Sub