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.

 

[CSmith]

You would need to give more information on procedures what you're attempting with this code as it does several different things, and the logic would most likely need adjusted.

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"?

Like this?

UCase(Right(cell.Offset(0, -6).Value,8)) = "CONTRACT"

 

[DanteAmor]

In the combined code if you do not allow to paste in the cells, then block 1 must go first.

Try this:

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("N:N")) Is Nothing Then
    For Each cell In Target
      If cell = "Yes" And Right(cell.Offset(0, -6).Value, 8) = "CONTRACT" Then
        MsgBox "Entry in row " & cell.Row & " requires review!", vbOKOnly, "ALERT!!!"
      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

 

[rhmkrmi]

Thanks DanteAmor.

When I use it, it disables what I had in BLOCK2.

Block2 checks the value in column B and then auto-populates some cells with word "Check" and color shading.

Thanks.

 

[DanteAmor]

I tried it and it works if you write "Home" in column B, fill in the cells.

You could describe what steps you take and how it should work.

You have 3 events, we have to synchronize them. But I need you to describe the sequence of what should happen in every action you take on the sheet.

 

[rhmkrmi]

Ok, thank you.

***BLOCK1***
This code makes sure that users cannot copy and past in the range defined.

***BLOCK2***
This block auto-populates and shades the cell ranges based on the value selected in column B.

The third block will be this one which I am struggling to combine with the other two blocks:

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 (UCase(Right(cell.Offset(0, -6).Value,8)) = "CONTRACT") Then MsgBox "Entry in row " & cell.Row & " requires review!", vbOKOnly, "ALERT!!!" End If Next cell End Sub

Thank you for your help.

 

[DanteAmor]

I understand what each block does. What you have to explain is what data you are going to put on the sheet and what you expect from the result. As I said the 3 blocks work for me. What problem do you have with the code I put?

 

[rhmkrmi]

Thanks DanteAmor!

I checked more carefully and you are perfectly correct, your whole restructured code works for my purposes.

Is it possible to make it get stuck with the pop-up message and not let the user proceed if the conditions are met in this section of the code:

'*** Loop through cells just updated in column N ***
If Not Intersect(Target, Range("N:N")) Is Nothing Then
For Each cell In Target
If cell = "Yes" And Right(cell.Offset(0, -6).Value, 8) = "CONTRACT" Then
MsgBox "Entry in row " & cell.Row & " requires review!", vbOKOnly, "ALERT!!!"
End If
Next cell
End If

Also, in the above bit, there is a flaw:
If the user first enters "Yes" in column N and then go to column H and enter "EXISTING CONTRACT", it does not alert the user.
If the user does it the other way, it does work but it let's them click on OK and proceed.

Thank you very much for all your help and patience.

 

[DanteAmor]

If the user first enters "Yes" in column N and then go to column H and enter "EXISTING CONTRACT", it does not alert the user.
If the user does it the other way, it does work but it let's them click on OK and proceed.

Check if the following is what you need.

'*** Loop through cells just updated in column N ***
  If Not Intersect(Target, Range("H:H, N:N")) Is Nothing Then
    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
        Range("H" & cell.Row, "N" & cell.Row).ClearContents
        cell.Select
        Application.EnableEvents = True
      End If
    Next cell
  End If

 

[rhmkrmi]

Thanks again DanteAMore.

This is working for me and I am grateful.

Is there a way we can make it persistent, i.e. keep popping up the message and not let exit cell if conditions are met instead of ClearContents?

Thanks again.