How to delete the content of the 2 cells to the right if active cell does meet criteria - excel

I have written the following code to input the date in the cell to the right if the active cell = 'yes' or 'no'. This part of the code is working perfectly fine but for some reason when the active cell doesn't meet the criteria then I want it to clear the content of the 2 cells to the right. Any advise would much appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will cause an input
'date and time in next 2 cells to the right when active cell is changed.
Set KeyCells = ActiveSheet.ListObjects("VW_P1_P2").ListColumns("C1 Made Contact?").Range
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target = "Yes" Or Target = "No" Then
ActiveCell.Offset(-1, 1).Value = Format(Now, "mm/dd/yyyy")
ActiveCell.Offset(-1, 2).Value = Format(Now, "hh:mm")
Else
ActiveCell.Offset(-1, 1).ClearContents
ActiveCell.Offset(-1, 2).ClearContents
End If
End If
End Sub

Several issues/improvements:
Use Me to refer to the parent worksheet, instead of ActiveSheet.
Avoid using ActiveCell, and instead use Target to refer to the changed cell(s).
Range(Target.Address) is redundant. Just use Target.
If Target is a multi-cell range, you can't compare it to "Yes" or "No", so use a loop.
You're changing the sheet programmatically, so best practice would be to temporarily disable events, and re-enable them at the end.
I'd suggest using .ListColumns("C1 Made Contact?").DataBodyRange instead of .ListColumns("C1 Made Contact?").Range. This would exclude the column header C1 Made Contact.
Instead of Format(Now, "mm/dd/yyyy"), you could just use Date.
Private Sub Worksheet_Change(ByVal Target As Range)
' The variable KeyCells contains the cells that will cause an input
'date and time in next 2 cells to the right when active cell is changed.
Dim KeyCells As Range
Set KeyCells = Me.ListObjects("VW_P1_P2").ListColumns("C1 Made Contact?").DataBodyRange
Dim rng As Range
Set rng = Application.Intersect(KeyCells, Target)
If Not rng Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell As Range
For Each cell in rng
If cell.Value = "Yes" Or cell.Value = "No" Then
cell.Offset(-1, 1).Value = Format(Now, "mm/dd/yyyy") ' or just Date
cell.Offset(-1, 2).Value = Format(Now, "hh:mm")
Else
cell.Offset(-1, 1).ClearContents
cell.Offset(-1, 2).ClearContents
End If
Next
End If
SafeExit:
Application.EnableEvents = True
End Sub
EDIT:
If KeyCells is multiple columns in your table, then you could use Union:
With Me.ListObjects("VW_P1_P2")
Dim KeyCells As Range
Set KeyCells = Union(.ListColumns("C1 Made Contact?").DataBodyRange, _
.ListColumns("C2 Made Contact?").DataBodyRange, _
.ListColumns("C3 Made Contact?").DataBodyRange)
End With

Related

How can I build For-Next-Loop in Change Event?

I've got a sheet with Data.
I want to calculate the difference between date now and the date which are in cells C3:C10. And the results are stored in cells D3:D10.
That part I got it so far.
But if someone manipulates the values in the result cells then the VBA should recalculate those cells and correct the results.
Private Sub Worksheet_Change(ByVal Target As Range)
For Zeile = 3 To 10
Sheets("Tabelle2").Cells(Zeile, "D") = WorksheetFunction.YearFrac(Sheets("Tabelle2").Cells(Zeile, "C"), Date)
If Sheets("Tabelle2").Cells(Zeile, "C") = 0 Then
Sheets("Tabelle2").Cells(Zeile, "D") = ""
End If
Next Zeile
End Sub
The first thing to do is check if the change has been made in C3:C10, you can use Intersect for that.
Then you should disable events to stop the code triggering itself, use Application.EnableEvents = False for that.
Next loop through Target in case more than one cell has been changed and perform the required actions/calculations.
Finally re-enable events using Application.EnableEvents = True
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim cell As Range
Dim Zeile As Long
Set rng = Intersect(Target, Range("C3:C10"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng.Cells
Zeile = cell.Row
If Cells(Zeile, "C") <> 0 Then
Cells(Zeile, "D") = Application.YearFrac(Cells(Zeile, "C").Value, Date)
Else
Cells(Zeile, "D") = ""
End If
Next cell
Application.EnableEvents = True
End If
End Sub
If you want the code to be triggered if a value is changed in either C3:C10 or D3:D10 change this,
Set rng = Intersect(Target, Range("C3:C10"))
to this.
Set rng = Intersect(Target, Range("C3:D10"))
You can also change the range address there if you want to further rows by changing 10.

How do I removed Conditional Formatting after its been applied?

I have a worksheet change macro that highlights the first 8 cells in a row if the last cell contains the word "Cancelled". This works fine. However the word cancelled is in a drop down menu and if you accidently select it the macro kicks in. If you change to another word in the same cell, I would like it to remove the condition and go back to normal. Can someone help me out with this. Im sure it is something simple that I'm missing.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If UsedRange.Rows.Count > 0 Then
If Trim(Cells(Target.Row, Target.Column)) <> "" And _
UCase(Cells(Target.Row, Target.Column)) = "CANCELLED" Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Interior.Color = vbRed
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Font.Color = vbWhite
ElseIf Trim(Cells(Target.Row, Target.Column)) <> "" And _
UCase(Cells(Target.Row, Target.Column)) <> "CANCELLED" Then
Cells.FormatConditions.Delete
End If
End If
ErrHandler:
'
End Sub
You don't "apply" and "remove". You "apply" in both cases, just that you apply different colours.
Private Sub Worksheet_Change(ByVal Target As Range)
Const TriggerClm As Long = 8 ' change to suit
Dim TriggerRng As Range
Dim TargetRng As Range
Dim IntCol As Long
' Here the first row is 2, presuming row 1 contains captions
Set TriggerRng = Range(Cells(2, TriggerClm), Cells(Rows.Count, TriggerClm).End(xlUp))
If Not Application.Intersect(Target, TriggerRng) Is Nothing Then
With Target
Set TargetRng = Range(Cells(.Row, TriggerClm - 7), Cells(.Row, TriggerClm))
If StrComp(CStr(.Value), "cancelled", vbTextCompare) Then
TargetRng.Interior.Pattern = xlNone
TargetRng.Font.Color = vbBlack
Else
TargetRng.Interior.Color = vbRed
TargetRng.Font.Color = vbWhite
End If
End With
End If
End Sub
Observe that I reasoned that a change can only be triggered if a cell in the 8th column is changed because only that cell is either "Cancelled" or not. My code's logic deviates from yours in this respect.

Adjacent cell changes value based on change event and condition in same row

I'm trying to get an adjacent cell on the same row to change value based on whether a desired range is either empty, or has at least one used cell.
If after the change event rng has at least one used cell, change adjacent cell value to ON.
Else, change adjacent cell value to OFF.
Basically ON when first value is entered in any cell in the range, stays ON while other values are added to the range, and OFF when the last cell's value has been deleted.
I can get it to ON, but when I delete the last used cell in the range, the value does not switch to OFF.
What am I missing?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCellsB, rng As Range
Set KeyCellsB = Range("A3:J3")
Set rng = Range(Cells(Target.Row, 1), Cells(Target.Row, 10))
If Not Application.Intersect(KeyCellsB, Range(Target.Address)) Is Nothing Then
If Not IsEmpty(rng) Then
Cells(Target.Row, 12).Value = "ON"
Else
Cells(Target.Row, 12).Value = "OFF"
End If
End If
End Sub
Update
Here is a impler version of the code, still not working. I need it to switch to off only after ALL cells in Range(Cells(Target.Row, 1), Cells(Target.Row, 3)) are empty
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A3:J3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Not IsEmpty(Range(Cells(Target.Row, 1), Cells(Target.Row, 3))) Then
Cells(Target.Row, 12).Value = "ON"
Else
Cells(Target.Row, 12).Value = "OFF"
End If
End If
End Sub

When copying bulk values into cell macro is not updating

Currently using this macro cell template off Microsoft, it works perfectly when I input data into the B column one by one but when I try to copy and paste data into B1:B10 the macro will not run and column A will not update. Also If I wanted the same macro for another range column would I have to make another function exact same and change the Set KeyCells = Range( : ) or can I add in a conditional statement in the same function?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("B1:B1000")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Cells(Target.Row, 2).Value = "A" Then
Cells.(Target.Row, 1).Value = "AA"
End If
If Cells(Target.Row, 2).Value = "B" Then
Cells.(Target.Row, 1).Value = "BB"
End If
End If
End Sub
Loop the intersection of the target cells and the desired range.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Intersect(Range("B1:B1000"), Target)
If Not KeyCells Is Nothing Then
Dim rng As Range
For Each rng In KeyCells
If rng.Value = "A" Then
rng.Offset(0, -1).Value = "AA"
ElseIf rng.Value = "B" Then
rng.Offset(0, -1).Value = "BB"
End If
Next rng
End If
End Sub

prevent duplicates in the range of cells

I have a macro which prevents duplicates within the range A:H
But I don't know how to change the macro so it prevents input of "[name] [space] [surname]" more than twice. There can be a number of "[name] [space] [surname]" in one cell
Option Explicit
Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cel As Range
Dim What As Variant
Set rng = ActiveSheet.UsedRange.Columns("A:H")
If Target.Value = "" Then Exit Sub
If Not Intersect(Target, rng) Is Nothing Then
What = "*" & Target.Value & "*"
For Each cel In rng.Cells
If cel.Value Like What Then
Target.ClearContents
MsgBox "Text already present!"
End If
Next cel
End If
End Sub

Resources