I am trying to use VBA so that I can input a value in cell B7 in sheet2 and then it would automatically populate in C7 in sheet3 and also work vice versa. I tried the code below and couldn't get it to work, any suggestions? Also would the code be the same for a string of a number?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo eh
If Not Intersect(Target, ThisWorkbook.Sheets("sheet 2").Range("B7")) Is Nothing Then
Application.EnableEvents = False
ThisWorkbook.Sheets("sheet 3").Range("C" & Target.Row - 0).Value = Target.Value
eh:
Application.EnableEvents = True
If Err <> 0 Then MsgBox Err & " " & Err.Description, , "Error in Worksheet_Change event, sheet 2"
End If
End Sub
A Workbook SheetChange: Same Value in Cells of Worksheets
Note that the code needs to be copied to the ThisWorkbook module.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsNames As Variant: wsNames = VBA.Array("sheet 2", "sheet 3")
Dim CellAddresses As Variant: CellAddresses = VBA.Array("B7", "C7")
Dim iCell As Range
Dim n As Long
For n = 0 To UBound(wsNames)
If StrComp(Sh.Name, wsNames(n), vbTextCompare) = 0 Then
Set iCell = Intersect(Sh.Range(CellAddresses(n)), Target)
If Not iCell Is Nothing Then
Application.EnableEvents = False
Me.Worksheets(wsNames(1 - n Mod 2)) _
.Range(CellAddresses(1 - n Mod 2)).Value = iCell.Value
Application.EnableEvents = True
End If
Exit For
End If
Next n
End Sub
Related
I have two codes depend on application events to run.
Code (1) change color of column_A If FilterMode is True on any column of ActiveSheet.
Code (2) Log changes of any cells in ActiveSheet and put in another sheet("Log").
Error raised if : Filtermode = False and any cells changed by fill handle (the small square in the lower-right corner of the selected cell) ,
I got this error
Method 'Undo' of object '_Application' failed
on this line Application.Undo on Code (2).
I tried to use to disable and enable events with code (1) with no luck.
any help will be appreciated.
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
'Code (1) change color of column_A If FilterMode is True on any column of active sheet.
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(196, 240, 255)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End Sub
' Code (2) Log Changes of Current Sheet and put in Sheet("Log")
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
Dim sh As Worksheet: Set sh = Sheets("Log")
Dim UN As String: UN = Environ$("username")
If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in "AK:XFD" is changed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'Avoide trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'Define RangeValue
putDataBack TgValue, ActiveSheet 'Reinsert changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
'Array("User Name", "Date,Time", "Work Order", "Column Label", "New Value", "Old Value")
Range(RangeValues(r)(1)).EntireRow.AutoFit
If Range(RangeValues(r)(1)).RowHeight < 53 Then
Range(RangeValues(r)(1)).RowHeight = 53
End If
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.Cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.Cells.count
arr(count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I figured out the issue, although the error rising with code (2) Worksheet_Change event ,
But actually SelectionChange event on code(1) is the real problem.
Apparently, when I drag down, it is sort of like selecting cells individually and all of them at the same time.
To solve this issue, a condition must be added to event SelectionChange to count the target cells:
If Target.Cells.CountLarge = 1 then
So I just modified the code to look like this in the SelectionChange part and it now works perfectly.
'Code (1)
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Cells.CountLarge = 1 Then
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(255, 0, 0)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End If
End Sub
In the meantime, I learned that Calculate event would be best choice to trapping a change to a filtered list as described on this link
https://www.experts-exchange.com/articles/2773/Trapping-a-change-to-a-filtered-list-with-VBA.html
I have the following problem. I need to log changes in a spreadsheet. My range goes from A1:M300000.
So far I have managed to log the address of the changed cell, the user, the old value, and the new value.
Now I would like to insert the following functions and need help. It's the first time I come into contact with VBA:
I also want my log file to show the value of a cell in another column. So I know which object it is. Example change cell B26 and now also A26 should be displayed in the log file.
Furthermore, I also want to log when new cells are inserted or existing records are deleted.
Here is my VBA code:
Option Explicit
Dim mvntWert As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim lngLast As Long
Set wks = Worksheets("Protokoll")
lngLast = wks.Range("A65536").End(xlUp).Row + 1
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
With wks
.Range("A" & lngLast).Value = Target.Address(0, 0)
.Range("B" & lngLast).Value = mvntWert
.Range("C" & lngLast).Value = Target.Value
.Range("D" & lngLast).Value = VBA.Environ("Username")
.Range("E" & lngLast).Value = Now
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
mvntWert = Target.Value
End Sub
I hope someone can help me. Thank you very much in advance.
greeting
ironman
Please, try the next code, I prepared yesterday for somebody else asking for a similar issue. It needs only one event and should do what you require here:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
Dim sh As Worksheet: Set sh = Worksheets("Protokoll")
Dim UN As String: UN = Application.userName
'sh.Unprotect "" 'it should be good to protect the sheet
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'define the RangeValue
putDataBack TgValue, ActiveSheet 'put back the changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
End If
Next r
'sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.cells.count
arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I'm trying to make a cell value dictate how many copies should be made. I'm trying to make it if the cell value goes down that it will delete the sheets that are higher than the value. I currently have the adding working no problem just can't figure out how to make it delete copies when the value gets smaller. I figure I could make a button do a check just trying to make it more automated.
Sub CreateDistro()
Dim i As Long
Dim Num As Integer
Dim Name As String
Dim xActiveSheet As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Set ActiveSheet = ActiveSheet
Num = Range("C1")
If Num > 1 Then
For i = 1 To Num
Name = ActiveSheet.Name
xActiveSheet.Copy After:=ActiveWorkbook.Sheets(Name)
ActiveSheet.Name = "Distro-" & i
Next
End If
xActiveSheet.Activate
Application.ScreenUpdating = True
End Sub
Problem of the code below: it reacts on the Range("C1") of all sheets!
You might want to use a named range or limit the number of possible sheets(e.g. minimum number of sheets = 2, template to be copied is sheet 2,only sheet1 has the Worksheet_Change code.
Sheet1:
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Call ChangeSheets(target)
End Sub
Module1:
Option Explicit
Sub ChangeSheets(ByVal target As Range)
Dim iCt As Integer
Dim Num As Integer
Dim maxSh As Integer
'If Not Intersect(Target, Range("C1")) Is Nothing Then
' MsgBox ("C1: " & Target.Value)
'End If
If target.Value <= 0 Then
MsgBox "Minimum worksheet count = 1!" & vbCrLf & "Nothing to do!"
Application.EnableEvents = False
target.Value = 1
Application.EnableEvents = True
Application.DisplayAlerts = False
maxSh = Sheets.Count
For iCt = maxSh To 2 Step -1
Sheets(iCt).Delete
Next iCt
Application.DisplayAlerts = True
Exit Sub
End If
If Worksheets.Count = target.Value Then
MsgBox "Worksheet count = " & target.Value & vbCrLf & "Nothing to do!"
Exit Sub
End If
'add some sheets
If Worksheets.Count < target.Value Then
Num = target.Value - Worksheets.Count
For iCt = 1 To Num
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Next iCt
Exit Sub
End If
'delete some sheets
If Worksheets.Count > target.Value Then
Num = Worksheets.Count - target.Value
Application.DisplayAlerts = False
maxSh = Sheets.Count
For iCt = 0 To Num - 1
Debug.Print maxSh - iCt; ": "; Sheets(maxSh - iCt).Name
Sheets(maxSh - iCt).Delete
Next iCt
Application.DisplayAlerts = True
Exit Sub
End If
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
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