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
Related
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
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.
I want data in the cells of column J to copy the data in the cells of column G once data is inputted into column G and not before.
However, prior to this replication taking place I would like to be able to manually update the price in the cells of column J.
See the attached photo for clarity.
Could anyone suggest a solution? I know VBA is a possibility, however, my Excel knowledge is not good enough to write code.
Yellow headings represent no formulas and blue represent formulas.
Excel_Worksheet_ TRADE LOG
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("C:C"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("G:G"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 12).ClearContents
Else
With .Offset(0, 12)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
A Simple Worksheet Change
If values in the column range from G2 to the bottom-most (last) cell of the worksheet, are changed manually or via code, the values of the cells in the corresponding rows in column J will be overwritten with the values from column G.
This solution is automated, you don't run anything.
Sheet Module e.g. Sheet1 (in parentheses in Project Explorer of Visual Basic Editor)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const sCell As String = "G2" ' Source First Cell
Const dCol As Variant = "J" ' Destination Column Id (String or Index)
Dim irg As Range ' Intersect Range
Dim cOffset As Long ' Column Offset
With Range(sCell)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
If irg Is Nothing Then Exit Sub
cOffset = Columns(dCol).Column - .Column
End With
Dim arg As Range ' Current Area of Intersect Range
Dim cel As Range ' Current Cell in Current Area of Intersect Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If Not IsError(cel.Value) Then
cel.Offset(, cOffset).Value = cel.Value
End If
Next cel
Next arg
End Sub
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
i have the following code which would auto-fill the date in column B once i add value's in column A.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date & " " & Time = "hh:mm:ss AM/PM"
End If
Next r
Application.EnableEvents = True
End Sub
what im looking for is to also add the current time to column C.
ok so i found what im looking for but it requires little modification where the date and time are being set.
below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("D:D")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Value > 0 Then
r.Offset(0, -3).Value = Date
r.Offset(0, -3).NumberFormat = "dd-mm-yyyy"
r.Offset(0, -2).Value = Time
r.Offset(0, -2).NumberFormat = "hh:mm:ss AM/PM"
Else
r.Offset(0, -3).Value = ""
r.Offset(0, -2).Value = ""
End If
Next r
Application.EnableEvents = True
End Sub
to auto-fill column E with date, instead of column A
and auto-fill column F with time, instead of column B
and if possible im trying to have the same process but another cell on the same sheet.
While you might look at using SpecialCells to do this in one hit rather than a loop, a simple mod to your code would be:
one-shot per range area method
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error Resume Next
For Each r In Inte.Areas
r.Offset(0, 1).Cells.SpecialCells(xlCellTypeBlanks) = Date
r.Offset(0, 2).Cells.SpecialCells(xlCellTypeBlanks) = Time
Next r
Application.EnableEvents = True
End Sub
initial answer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = vbNullString Then r.Offset(0, 1).Value = Date
If r.Offset(0, 2).Value = vbNullString Then r.Offset(0, 2).Value = Time
Next r
Application.EnableEvents = True
End Sub
if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target adjacent column blank cells adjacent cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
If WorksheetFunction.CountBlank(Target.Offset(, 1)) = 0 Then Exit Sub '<--| exit if no blank cells in target adjacent column
With Target.Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference blank cells in target adjacent column
.Value = Date '<--| set referenced cells value to the current date
.Offset(, 1).Value = Time '<--| set referenced cells adjacent ones value to the current time
End With
Application.EnableEvents = True
End Sub
While if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target two columns offset blank cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
On Error Resume Next
Target.Offset(, 1).SpecialCells(xlCellTypeBlanks).Value = Date '<--| set target adjacent column blank cells to the current date
Target.Offset(, 2).SpecialCells(xlCellTypeBlanks).Value = Time '<--| set target two columns offset blank cells to the current time
Application.EnableEvents = True
End Sub
where the On Error Resume Next is there to avoid two distinct If WorksheetFunction.CountBlank(someRange) Then someRange.SpecialCells(xlCellTypeBlanks).Value = someValue statements
Normally you would avoid On Error Resume Next statement and ensure you're handling any possible errors.
But in this case, being it confined to the last two statements of a sub, I think it's a good trade off in favour of code readability without actually loosing its control