I need to add cell A to cell B of the same row and then reset cell A to zero. I did some searching and found this code that works perfectly, but I need to have it work for an entire column not just one row.
So, all of column A should add to column B, but only on the same row. Here is the code I found:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = Range("a1").Address Then
Range("b1") = Range("b1") + Range("a1")
Range("a1").ClearContents
End If
Application.EnableEvents = True
End Sub
And:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("A1")
If Intersect(Target, A1) Is Nothing Then
Else
Application.EnableEvents = False
With A1
.Offset(0, 1) = .Offset(0, 1) + .Value
.ClearContents
End With
Application.EnableEvents = True
End If
End Sub
Both sets of code work just fine to add cell A to B and reset A to zero, but I want this to work for the entire (column A and B) and all by row.
That is a picture of what I would like. I hope that this was clear and easy to understand. I appreciate any help that anyone can provide. I really appreciate it. Thank you.
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim T As Range, r As Range
Set T = Intersect(Target, Range("A:A"))
If T Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In T
With r
.Offset(0, 1).Value = .Offset(0, 1).Value + .Value
.ClearContents
End With
Next r
Application.EnableEvents = True
End Sub
Related
I need to copy the contents of a cell in a particular column to another corresponding column on change so the old value is moved. Only wants to work for a particular column.
Private sub Worksheet_Change(ByVal Target As Range)
if Target.Range("L:L") then
'set I cell value = to original L cell value
ActiveCell.Offset(0,-3).Value = ActiveCell.Value
End If
End Sub
This code should do what you want. Please take note of the comments which explain some limitations I have imposed on the action of this procedure. The rule to follow is to not give it more power than it needs to do the job you want it to do.
Private Sub Worksheet_Change(ByVal Target As Range)
' 027
Dim Rng As Range
' don't react if the changed cell is in row 1 or
' if it is more than 1 row below the end of column L
Set Rng = Range(Cells(2, "L"), Cells(Rows.Count, "L").End(xlUp).Offset(1))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
' skip if more than 1 cell was changed
' meaning, exclude paste actions
If .Cells.CountLarge = 1 Then
.Offset(0, -3).Value = .Value
End If
End With
End If
End Sub
This will save the previous value in column I:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant
If Target.Count > 1 Then Exit Sub
If Intersect(Range("L:L"), Target) Is Nothing Then Exit Sub
With Application
v = Target.Value
.EnableEvents = False
.Undo
Target.Offset(0, -3).Value = Target.Value
Target.Value = v
.EnableEvents = True
End With
End Sub
EDIT#1:
To update L without triggering the event, use something like:
Sub ScriptThatUpdatesColumn_L()
Application.EnableEvents = False
Range("L5").Value = "just me"
Application.EnableEvents = True
End Sub
The code below will add contents of A to B and then clear A across the entire column. How do I duplicate this function to have multiple columns with their own targets inside the same sub? Do I have to write a private sub for each?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim T As Range, r As Range
Set T = Intersect(Target, Range("A:A"))
If T Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In T
With r
.Offset(0, 1).Value = .Offset(0, 1).Value + .Value
.ClearContents
End With
Next r
Application.EnableEvents = True
End Sub
Thank you!
Single column:
Try using Select Case with Target.Column to determine what to do based on column that had event. Adding a GetLastRow function, following helpful comment from #AJD, to ensure only looping populated column range.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Columns.Count <> 1 Then Exit Sub
Select Case Target.Column
Case 1
'col A do something
ClearRange Target
Case 2
'col B do something
ClearRange Target
'Etc
End Select
Application.EnableEvents = True
End Sub
Public Sub ClearRange(ByVal T As Range) '<== This works on the basis Target is a single column
Dim r As Range, loopRange As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets(T.Parent.Name)
Set loopRange = ws.Range(ws.Cells(1, T.Column), ws.Cells(GetLastRow(ws, T.Column), T.Column))
If loopRange Is Nothing Then Exit Sub
'Debug.Print loopRange.Address
For Each r In loopRange
With r
.Offset(0, 1).Value = .Offset(0, 1).Value + .Value
.ClearContents
End With
Next r
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
tl;dr;
Multi-column:
You can re-write yours as follows. Though I am not sure what happens with multiple columns. Say, columns A:B, simplest case, were Target, does A get looped transfer and added to B, A gets cleared, B gets looped, added to C and B gets cleared? I wasn't really clear so haven't written anything for the inner part. I simply addressed the title of how to add more targets. Happy to update upon clarification.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("A:A")) Is Nothing Then
End If
If Not Intersect(Target, Range("B:B")) Is Nothing Then
End If
Application.EnableEvents = True
End Sub
The purpose of this code is to update the date in a cell as a certain cell's contents are changed.
Since this was originally coded inside a sub, I now need to expand this code to a range of multiple cells. Ie. At this moment, the code only takes cell D4 and updates cell L4, I want to be able to drag this function down so it can reach a multiple range of cells; take D5 and update L5 etc.
Here's my code as the sub:
Dim oldValue
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Worksheet.Range("D4").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("D4")) Is Nothing Then
If oldValue <> Target.Worksheet.Range("D4").Value Then
Target.Worksheet.Range("L4").Value = Date
End If
End If
End Sub
The problem here, is that I don't know how to properly expand my code to match a further selection of cells. Here's my attempt:
Dim oldValue
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Worksheet.Range("D4", "D21").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("D4", "D21")) Is Nothing Then
If oldValue <> Target.Worksheet.Range("D4", "D21").Value Then
Target.Worksheet.Range("L4", "L21").Value = Date
End If
End If
End Sub
EDIT: The sub I have written only applies to one cell, I am trying to work out a way to have it spread out to a certain selection of cells. Ie. D4:D12 which updates the date in L4:L12 accordingly.
If anyone could help me, that would be greatly appreciated.
Try the following code:
Dim oldValue()
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Me.Range("D4:D12").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("D4:D12")) Is Nothing Then
Application.EnableEvents = False
Dim c As Range
For Each c In Intersect(Target, Me.Range("D4:D12"))
'Check value against what is stored in "oldValue" (row 4 is in position 1, row 5 in position 2, etc)
If oldValue(c.Row - 3, 1) <> c.Value Then
'Update value in column L (8 columns to the right of column D)
c.Offset(0, 8).Value = Date 'or possibly "= Now()" if you need the time of day that the cell was updated
End If
Next
Application.EnableEvents = True
End If
End Sub
Set up a hidden sheet to hold the old values.
Sub SetupMirrorValues()
With Worksheets.Add
.Name = "MirrorValues"
.visibilty = xlSheetVeryHidden
.Range("D4:D10,D12,D14:D20") = Worksheets("Sheet1").Range("D4:D10,D12,D14:D20")
End With
End Sub
In the Worksheet_Change event handler, you would check the Target cells that intersect with the range you want to monitor. If there are differences then you update the timestamp and the cell on the hidden sheet that corresponds to the changed cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim cell As Range, DRange As Range
Set DRange = Range("D4:D10,D12,D14:D20")
If Not Intersect(DRange, Target) Is Nothing Then
For Each cell In Intersect(DRange, Target)
If cell.Value <> Worksheets("MirrorValues").Range(cell.Address) Then
cell.EntireRow.Cells(1, "L").Value = Now
Worksheets("MirrorValues").Range(cell.Address) = cell.Value
End If
Next
End If
Application.EnableEvents = True
Application.ScreenUpdating = False
End Sub
I have been looking for days to solve this and have only come up with half the solution.
What I can do:
I would simply like to have one cell turn green inside with an x inserted when another cells data has the word "Complete" inside it.
What I cannot do:
I would like that same cell that turned green with an x inserted into it when the word "Complete" is changed to "Rework" to stay green with an x.
So Cell A1 is blank then in cell B1 the word "Complete" is added. Then cell A1 changes to green and has an x inside it. If later B1 changes to "Rework" I would like A1 to stay green with the x inside. So I can know that at one time the status of B1 was at one time "Complete"
I have been trying Conditional Formatting with rules but cannot get it to stay. I think the "Stop If True" check box within would be part of the solution but not sure what the code would be.
I already have a different macro running on this sheet so if the answer is a macro I will need it to be added to it. Below is the macro in the sheet already. Thank you.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count)) Is Nothing Then
If Target.Count < Columns.Count Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim r As Range
For Each r In Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Ideally you'd split this up into separate subs to handle each of the change types, but this should give you an idea:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, r as Range
'skip full-row changes (row insert/delete?)
If Target.Columns.Count = Columns.Count Then Exit Sub
Set rng = Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
Set rng = Intersect(Target, Range("B:B"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
If r.Value = "Complete" Then
With r.Offset(0, -1)
.Value = "x"
.Interior.Color = vbGreen
End With '<<EDIT thanks #BruceWayne
End If
Next r
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
You'll need two worksheet events, and some If statements. The following should help you get started, unless I'm overlooking something.
Dim oldVal as String ' Public variable
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Debug.Print Target.Address
If Target.Cells.Count <> 1 Then Exit Sub
oldVal = Target.Value
End Sub
The above will make note of the oldValue.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newVal As String
newVal = Target.Value
If newVal = oldVal Then
Debug.Print "Same Values"
ElseIf oldVal = "Complete" And newVal = "Rework" Then
Debug.Print "Stay green with X"
ElseIf oldVal = "" And (newVal = "Complete" Or newVal = "complete") Then
Debug.Print "Change cell to Green, add an 'X'"
Target.Interior.ColorIndex = 10
Target.Value = Target.Value & " x"
End If
End Sub
Then, add/tweak those If statements as necessary, and add the color changing/reverting code to the appropriate block.
(There may of course be a better mousetrap, but I think this should get you going).
I have a worksheet with values depending on Cell A. If a row in column A contains a value then cells from Columns B through H will be changed accordingly.
If Cell of Column A is empty I want to reset the cells from columns D through F.
I wrote down the following VBA Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Integer
For n = 5 To 75
Application.EnableEvents = False
If VarType(Cells(n, 1)) = vbEmpty Then
Cells(n, 4).ClearContents
Cells(n, 5).ClearContents
Cells(n, 6).ClearContents
Application.EnableEvents = True
End If
Next n
End Sub
The "FOR" Loop is annoying, and making the Excel to pause for 1 second or more after any entry to any Cell, can anyone help me correct the above code to do what I need to do without the "FOR" loop.
You are using a Worksheet_Change event and you iterating through 70 rows each time something changes.. this is a bad approach for this kind of problem and that's why there is a delay.
Instead, try
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long
If Target.Column = 1 Then
If IsEmpty(Cells(Target.Row, 1)) Then
Range("B" & Target.Row & ":F" & Target.Row).ClearContents
End If
End If
End Sub
this will only clear the cells if you remove a value from column A => when cell in column A is empty
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Mid(Target.Address(1, 1), 1, 2) = "$A" Then
If Target.Cells(1, 1).Value = "" Then
For i = 4 To 6
Target.Cells(1, i).Value = ""
Next i
End If
End If
End Sub
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("A5:A75")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("D" & rw & ":F" & rw).ClearContents
End If
Next r
Application.EnableEvents = True
End Sub
It should have minimal impact on timing.
Use a range object.
The following line of code will print the address of the Range we'll use to clear the contents. The first cells call gets the upper left corner of the range, the second cells call gets the lower right corner of the range.
Private Sub test()
Debug.Print Range(Cells(5, 4), Cells(75, 6)).Address
End Sub
We apply this to your code like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
Application.EnableEvents = True
End If
End Sub
One final sidenote: You should use an error handler to make sure events are always enabled when the sub exits, even if an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
End If
ExitSub:
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Oh Noes!", vbCritical
Resume ExitSub
End Sub
You should disable events and cater for multiple cells when using the Change event.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Columns("A"), Target)
If rng1 Is Nothing Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each rng2 In rng1.Cells
If IsEmpty(rng2.Value) Then rng2.Offset(0, 1).Resize(1, 5).ClearContents
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
For those that need to have data entered in one cell cleared (in a column) when there's a change in another column use this, which is a modification of Gary's Student.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("D:D")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("L:L").ClearContents
End If
Next r
Application.EnableEvents = True
End Sub