How do I do this change for 3 pairs of separate cells. I know this 1st code works for 1 pair of cells by putting it on two diff worksheets
Private Sub Worksheet_Change(ByVal Target As Range)
Dim p1 As Range, p2 As Range
Set p1 = Range("L268")
Set p2 = Sheets("Calculator").Range("J2")
If Intersect(Target, p1) Is Nothing Then Exit Sub
Application.EnableEvents = False
p2.Value = p1.Value
Application.EnableEvents = True
End Sub
and then this on the other
Private Sub Worksheet_Change(ByVal Target As Range)
Dim p1 As Range, p2 As Range
Set p1 = Range("J2")
Set p2 = Sheets("Proposal Summary").Range("L268")
If Intersect(Target, p1) Is Nothing Then Exit Sub
Application.EnableEvents = False
p2.Value = p1.Value
Application.EnableEvents = True
End Sub`
but how do I add in two other pairs of cells I also want to equal each other?
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim p1 As Range, p2 As Range
Dim a1 As Range, a2 As Range
Dim h1 As Range, h2 As Range
Set p1 = Range("J2")
Set p2 = Sheets("Proposal Summary").Range("L268")
Set a1 = Range("J3")
Set a2 = Sheets("Proposal Summary").Range("L271")
Set h1 = Range("J4")
Set h2 = Sheets("Proposal Summary").Range("L274")
If Intersect(Target, p1) Is Nothing Then Exit Sub
p2.Value = p1.Value
If Intersect(Target, a1) Is Nothing Then Exit Sub
a2.Value = a1.Value
If Intersect(Target, h1) Is Nothing Then Exit Sub
h2.Value = h1.Value
Application.EnableEvents = True
End Sub
THANK YOU!!!
If I've read the ranges involved correctly you should be able to combine the whole thing like this.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("J2:J4")) Is Nothing Then
Sheets("Proposal Summary").Range("L268").Offset((Target.Row - 2) * 3).Value = Target.Value
End If
Application.EnableEvents = True
End Sub
If you want this to work the other way, i.e. update the other sheet when a value changes on Proposal Summary you could use this.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("L268, L271, L274")) Is Nothing Then
Sheets("Calculator").Range("J2").Offset((Target.Row - 268) / 3).Value = Target.Value
End If
Application.EnableEvents = True
End Sub
Related
By using Concatenate to combine 6 entries and then evaluate them, my worksheet changes the value of cell AA1 to be greater than 1 when a duplicate entry of any other row has been made. The Excel formula works well, but I need help on the VBA side: The code below is part of a Private Sub Worksheet_Change(ByVal Target As Range) with many operations that continue to work perfectly, while this does nothing at all. I already have Conditional Formatting highlighting the duplicate row entries, but I need a msg box to tell users what they have done wrong and how to fix it.
Dim fng As Range
Set fng = Range("$AA$1")
If Not Intersect(Target, fng) Is Nothing Then
If Target.Value > 1 Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End If
In case it makes more sense to see the entire code, he it is:
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Worksheet.Unprotect Password:="Cami8"
Dim rng As Range
Set rng = Range("F3:F10001")
If Not Intersect(Target, rng) Is Nothing Then
Target.Offset(0, 4) = Now
ActiveWorkbook.Save
End If
Application.EnableEvents = True
Dim ung As Range
Set ung = Range("J3:J10005")
If Not Intersect(Target, ung) Is Nothing Then
Target.Offset(-1, -3).Locked = True
End If
Application.EnableEvents = True
Dim wng As Range
Set wng = Range("J3:J10005")
If Not Intersect(Target, wng) Is Nothing Then
Target.Offset(-1, -4).Locked = True
End If
Application.EnableEvents = True
Dim xng As Range
Set xng = Range("J3:J10005")
If Not Intersect(Target, xng) Is Nothing Then
Target.Offset(-1, -5).Locked = True
End If
Application.EnableEvents = True
Dim kng As Range
Set kng = Range("J3:J10005")
If Not Intersect(Target, kng) Is Nothing Then
Target.Offset(-1, -6).Locked = True
End If
Application.EnableEvents = True
Dim qng As Range
Set qng = Range("J3:J10005")
If Not Intersect(Target, qng) Is Nothing Then
Target.Offset(-1, -7).Locked = True
End If
Application.EnableEvents = True
Dim cng As Range
Set cng = Range("C3:E10001")
If Not Intersect(Target, cng) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Target.NumberFormat = "General"
Application.EnableEvents = True
End If
Dim sng As Range
Set sng = Range("E3:E10002")
If Not Intersect(Target, sng) Is Nothing Then
If Len(Target) > 1 Then
MsgBox "You entered GRADE with a letter and a space -- Click on the cell and enter only a letter", vbOKOnly, "OOPS!"
End If
End If
Dim fng As Range
Set fng = Range("$AA$1")
If Not Intersect(Target, fng) Is Nothing Then
If Target.Value > 1 Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End If
Target.Worksheet.Protect Password:="Cami8"
End Sub
Thanks for the great tip about Worksheet_Calculate, since that did the trick! I just removed the code I had in Worksheet_Change and input this:
Private Sub Worksheet_Calculate()
Const lVal As Long = 2
Dim rCell As Range
Set rCell = Range("AA1")
If rCell.Value = lVal Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End Sub
Please help me with my macro below it doesn't work correctly when I changed value in activecell.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim KeyCells As Range
kolumna = ActiveCell.Column
wiersz = ActiveCell.Row
komorka = Cells(wiersz, kolumna).Address
Set KeyCells = Range(komorka)
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Target.Offset(0, 1) = Target * 12
End If
Application.EnableEvents = True
End Sub
but when I such code as below it works but it works when I change value in cell: $D$3
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim KeyCells As Range
Set KeyCells = Range("$D$3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Target.Offset(0, 1) = Target * 12
End If
Application.EnableEvents = True
End Sub
so the problem with my code is here:
komorka = Cells(wiersz, kolumna).Address
Thanks a lot for your help
Move After Return
Application.MoveAfterReturn
It will not work if MoveAfterReturn is set to True, because when you change a value the cursor moves to the next cell which becomes the ActiveCell so they never intersect (Correction: it will work anyway if you're in column A and use the Left arrow to confirm the entry or in A1 use the Up arrow, etc.).
It could work if you set MoveAfterReturn to False, so I wrote the procedure to toggle it. Add a Button or a CommandButton and use it to enable or disable it when necessary.
Note that you have to confirm the cell entry with Enter. The arrows will not do.
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.MoveAfterReturn Then
If Not Application.Intersect(ActiveCell, Target) Is Nothing Then
Dim cValue As Variant: cValue = Target.Value
If IsNumeric(cValue) Then
Target.Offset(0, 1).Value = CDbl(cValue) * 12
End If
End If
End If
End Sub
Standard Module e.g. Module1
Option Explicit
Sub toggleMAR()
With Application
If .MoveAfterReturn Then
.MoveAfterReturn = False
Else
.MoveAfterReturn = True
End If
End With
End Sub
I want a macro that automatically multiplies a given column by a set number. This number will be different for each column. I am only able to apply it to one column so far. I can't have it done for any other:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = Target.Value * 300
Application.EnableEvents = True
If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = Target.Value * 500
Application.EnableEvents = True
End Sub
Perhaps like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim rng As Range
Set rng = Intersect(Target, Me.Range("B:B")
If Not rng Is Nothing Then
rng.Value = rng.Value * 300
End If
Set rng = Intersect(Target, Me.Range("C:C"))
If Not rng Is Nothing Then
rng.Value = rng.Value * 500
End If
SafeExit:
Application.EnableEvents = True
End Sub
EDIT:
This is probably a better approach if you have more than two columns (and they are contiguous):
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B:F")) Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim rng as Range
For Each rng In Intersect(Target, Me.Range("B:F"))
Dim multiplier As Long
Select Case rng.Column
Case 2 ' column B
multiplier = 300
Case 3 ' column C
multiplier = 500
Case 4 ' column D
multiplier = 400
Case 5 ' column E
multiplier = ...
Case 6 ' column F
multiplier = ...
End Select
If IsNumeric(rng.Value) Then
rng.Value = rng.Value * multiplier
End If
Next
End If
SafeExit:
Application.EnableEvents = True
End Sub
Got a problem and looking for some advice. I've been using the below code for a while now in Excel, it clears the contents of column B if cell A is empty. It works great, but I now need it to work for a specific range (A6:B35). Any ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
You need to test if the active cell (target) falls in the range A6:A35. Like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If not intersect(target, range("A6:A35")) is nothing then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
Application.EnableEvents = True
End If
End if
exitHandler:
End Sub
You should also indent your code so it is more readable. It will help with loops and IF statements.
something like
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Target, Range("A6:B35"))
If rng1 Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rng2 In rng1
If rng2.Validation.Type = 3 Then rng2.Offset(0, 1).ClearContents
Next
Application.EnableEvents = True
End Sub
How can we find the last item entered within a column?(note that the last entered item may be A4, while we have data till A1000)
Thanks
If you need the value of the last item entered, then include this event macro in the worksheet code area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CellsToWatch As Range, LastValue As Range
Set CellsToWatch = Range("A1:A1000")
Set LastValue = Range("B1")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, CellsToWatch) Is Nothing Then Exit Sub
Application.EnableEvents = False
LastValue.Value = Target.Value
Application.EnableEvents = True
End Sub
If you need the location of the last item entered, then use this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CellsToWatch As Range, LastValue As Range
Set CellsToWatch = Range("A1:A1000")
Set LastValue = Range("B1")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, CellsToWatch) Is Nothing Then Exit Sub
Application.EnableEvents = False
LastValue.Value = Target.Address
Application.EnableEvents = True
End Sub
The result will be stored in cell B1
I would create a helper column. This would be a date stamp that is generated using VBA. You can hide we'll just call it column B.
this will go under worksheet change event
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Application.EnableEvents = False
Me.Cells(Target.Row, 2) = Format(Date + Time, "mm/dd/yyyy h:nn:ss")
Application.EnableEvents = True
End If End Sub
Please note that in Me.Cells(Target.Row,2) the 2 is going to change according to which column you want your date in.
this will go in a separate Module:
Sub get_LastEntered()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim last_Time As Date
Dim last_Row As Long
Dim last_Row_Changed As Long
last_Row = ws.Cells(Rows.Count, 2).End(xlUp).Row
last_Time = Application.WorksheetFunction.Max(ws.Range("B1:B" & last_Row))
last_Row_Changed = Application.WorksheetFunction.Match(last_Time, ws.Range("B1:B" & last_Row),0)
MsgBox "The last Cell that you changed was:" & last_Row_Changed
End Sub