Unfortunately Worksheet_change is not working for me. I am using a Sheet where the first column is NOW() function. If I click anywhere in the excel the time on this cell changes, but the Worksheet_Change just don't detect it.
A2 is using =NOW()
Anyone knows how to fix this issue? I have tried several different ways and no one works.
'Option Explicit
'Option Base 1
Dim xVal As Double
'Update by Extendoffice 2018/8/22
'Private Sub Worksheet_Calculate(ByVal Target As Range)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = Range("$A$2").Address Then
'Rows(3).Insert Shift:=xlDown
'Range("$A$3").Value = Now
'Range("$B$3").Value = xVal
'Range("$C$3").Value = Range("$C$2").Value
'Else
If xVal <> Range("$B$2").Value Then
Debug.Print xVal & " <- xVal IF"
Debug.Print Range("B2").Text & "<- Text IF"
Rows(3).Insert Shift:=xlDown
Range("$A$3").Value = Now
Range("$B$3").Value = xVal
Range("$C$3").Value = Range("$C$2").Value
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
xVal = Range("$B$2").Value
End Sub
A Worksheet_Calculate Event Study
Google Drive
Cell A2 in worksheet Sheet1 contains the formula =B2.
Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
WsCalc
End Sub
' Only to trigger the calculate event when different cell is selected.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ThisWorkbook.Worksheets("Sheet1").Range("B2") = Int(Rnd() * 2 + 1)
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
WsCalc
End Sub
Module1
Option Explicit
Public lngSource As Long ' Current Source Value
Sub WsCalc()
Dim rngSource As Range ' Source Cell Range
' Create a reference to Source Cell Range (rngSource).
Set rngSource = ThisWorkbook.Worksheets("Sheet1").Range("A2")
' When the workbook opens, Current Source Valuec (lngSource) is equal to "".
' Therefore:
If lngSource = 0 Then
' Initialize Current Source Value (lngSource) i.e. write value
' of Source Cell Range (rngSource) to Current Source Value (lngSource).
lngSource = rngSource.Value
MsgBox "Monitoring started (lngSource=" & lngSource & ")."
Exit Sub
End If
' If you need disabling events, this is how you implement it. Not needed
' in this code.
' Application.EnableEvents = False
On Error GoTo ProgramError
' Check value of Source Cell Range (rngSource)
' against Current Source Value (lngSource).
If rngSource.Value <> lngSource Then
' The value has changed.
MsgBox "The value has changed from '" & lngSource & "' to '" _
& rngSource.Value & "'."
lngSource = rngSource.Value
Else
' The value hasn't changed (usually no code).
MsgBox "Value NOT changed, still '" & lngSource & "'"
End If
SafeExit:
' MsgBox "Enabling events before exiting."
' Application.EnableEvents = True
Exit Sub
ProgramError:
' Improve this error handling.
MsgBox "An unexpected error occurred."
On Error GoTo 0
GoTo SafeExit
End Sub
Related
I know how to clear one cell based on another cell being changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("K2")) Is Nothing Then
Range("L2").ClearContents
End If
End Sub
I want this to pertain all the way down each column.
If "K3" is changed, clear "L3", but not "L2" or any other cell not pertaining to that row change.
Use Offset property.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("K:K")) Is Nothing Then
target.offset(,1).ClearContents
End If
End Sub
Try the following.
Target.Offset(0, 1) will clear the cell to the left of the modified cell.
If Not Intersect(Target, Range("K:K")) Is Nothing Then
Target.Offset(0, 1).ClearContents
End If
If the user modifies more than one cell at once (eg with Copy&Paste), you might want to check every single cell. And as you modify a cell from the same worksheet, you should switch off Event handling while your code is running - else your modification will trigger another call of your Change-Routine
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Goto Change_Exit
Dim cell As Range
For Each cell In Target
If Not Intersect(cell, Range("K:K")) Is Nothing Then
cell.Offset(0, 1).ClearContents
End If
Next
Change_Exit:
Application.EnableEvents = True
End Sub
A Worksheet Change: ClearContents
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError ' enable error handling
Const sfcAddress As String = "K2"
Const dCol As String = "L"
' Reference the column range (exclude above the first cell (header(s)))
Dim scrg As Range
With Range(sfcAddress)
Set scrg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Reference the intersecting range.
Dim srg As Range: Set srg = Intersect(scrg, Target)
If srg Is Nothing Then Exit Sub
Dim drg As Range
Dim sarg As Range ' copy/pasted multiple areas are only possible via VBA
' Combine the areas into a range.
For Each sarg In srg.Areas
If drg Is Nothing Then Set drg = sarg Else Set drg = Union(drg, sarg)
Next sarg
' 'drg' can't be 'Nothing' since 'srg' is already 'something'.
'If drg Is Nothing Then Exit Sub
' Prevent retriggering this or triggering any other event.
Application.EnableEvents = False
Intersect(drg.EntireRow, Columns(dCol)).ClearContents
SafeExit:
On Error Resume Next ' defer error handling; prevent endless loop if error
' Enable events if they were disabled.
If Not Application.EnableEvents Then Application.EnableEvents = True
On Error GoTo 0 ' disable error handling
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
Sub MultiRangeTest()
Range("K2:K10,K16:K20").Value = "Test"
End Sub
I want the user's name and the date to be entered into a specified column when any change is made.
I also have a snippet of code that forces any data that is pasted into the sheet to be pasted as values so the sheet's formatting is maintained.
I was able to write code that functioned properly, but the event was also being triggered even when the user double clicked in a cell and clicked out of the cell (i.e., no change was made). A user could accidentally click into a cell and leave it without making changes, but their name would be left behind as having made an edit.
I tried to incorporate this solution. Here is a simplified version of my code:
Private Sub Worksheet_Change(ByVal Target as Range)
Dim DesiredRange as Range
Dim TOld, TNew as String
Set DesiredRange as 'Whatever range I'm using
If Not Intersect(Target, DesiredRange) is Nothing Then
TNew = Target.Value
With Application
.EnableEvents = False
.Undo
End With
TOld = Target.Value
Target.Value = TNew
If Application.CutCopyMode = xlCopy Then
Application.EnableEvents = False
Application.Undo
Target.PasteSpecial Paste:=xlPasteValues
Application.EnableEvents = True
End if
If TOld <> TNew Then
Target.Offset(0, 23 - Target.Column) = Application.Username & vbNewLine & Date
End If
Application.EnableEvents = True
End if
End Sub
I am encountering the following issue:
When a user double clicks into a cell and clicks into another cell, the event is not triggered (i.e., the user's name and date is not left in the cell) but the active cell is reverted into the original cell, rather than the one they clicked into after double-clicking.
So a user would double click into a cell, do nothing, then click into another cell, and the active cell would revert to the first cell they were in.
This is also happening after the user inputs their change into the cell and presses enter.
I also encounter an error when something is pasted into the sheet, causing the code to not execute properly.
Prevent Worksheet Change When No Change
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Dim srg As Range: Set srg = Range("B5:E10")
Dim irg As Range: Set irg = Intersect(srg, Target)
If irg Is Nothing Then Exit Sub
Dim coll As Collection: Set coll = New Collection
Dim iCell As Range
For Each iCell In irg.Cells
coll.Add iCell.Value
Next iCell
With Application
.EnableEvents = False
.Undo
End With
Dim drg As Range
Dim n As Long
For Each iCell In irg.Cells
n = n + 1
If iCell.Value <> coll(n) Then
iCell.Value = coll(n) ' write different value
If drg Is Nothing Then ' combine the cells for user and date
Set drg = iCell
Else
Set drg = Union(drg, iCell)
End If
End If
Next iCell
If Not drg Is Nothing Then
' Use 'Now' while testing or you will see no difference.
' Later switch to 'Date'.
Intersect(drg.EntireRow, Columns("W")).Value = Application.UserName _
& vbNewLine & Format(Now, "mm/dd/yyyy hh:mm:ss") ' Date
End If
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I want to prevent copy pasting data in excel if the data is not unique. Im using the following macro.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedCells As Range
Dim Cell As Range
Set AffectedCells = Intersect(Target, Target.Parent.Range("A:A"))
If Not AffectedCells Is Nothing Then
For Each Cell In AffectedCells
If CountIf(Range("A:A"),A1) >2 Then
MsgBox "The data """ & Cell.Value & """ inserted in " & Cell.Address & " in column A is duplicste. We undo!", vbCritical Application.Undo 'undo insert
Exit Sub
End If
Next Cell
End If
End Sub
It is still allowing the data to be pasted.
I tried letting excel not save itself if the value is duplicate but it is still saving.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rngCell As Range
Dim lngLstRow As Long lngLstRow = Sheet1.UsedRange.Rows.Count
For Each rngCell In Sheet1.Range("A1:A" & lngLstRow)
If CountIf(Range("A:A"),A1) > 2 Then
MsgBox "Please enter unique value " & rngCell.Address
rngCell.Select
End If
Next
End Sub
I need users to be able to fill in one row to generate a P.O., and when the P.O. is generated the row below would be unhidden. The P.O. depends on column C, E and G to be filled in.
This code only unhides a row if one of the requirements are met. It also makes the workbook lag.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Row < 14 Or Target.Row > 5000 Or Target.Column < 3 Or Target.Column < 5 Or Target.Column <> 7 Then GoTo ExitMe
Rows(Target.Row + 1).Hidden = False
ExitMe:
Application.EnableEvents = True
End Sub
I need one row to be filled in at a time so the P.O. can be generated properly. If there is a better way please let me know.
This macro also conflicts with my macro for protecting changed cells when the worksheet is saved. This is the error that appears: Run-time error '1004': Unable to set hidden property of the Range class.
It is placed in ThisWorkbook
Option Explicit
Private bRangeEdited As Boolean
Private WithEvents ws As Worksheet
Private Sub Workbook_Open()
Set ws = Range("A14:Y3000").Parent
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sMSG As String
sMSG = "saving the workbook will lock the cells you have entered data into." & vbLf
sMSG = sMSG & "Do you want to go ahead ?"
If Not bRangeEdited Then GoTo Xit
If Not Me.ReadOnly Then
With Range("A14:Y3000")
If MsgBox(sMSG, vbExclamation + vbYesNo) = vbNo Then
Cancel = True
GoTo Xit
End If
.Parent.Unprotect "password"
If .SpecialCells(xlCellTypeBlanks).Address <> .Address Then
.SpecialCells(xlCellTypeConstants).Locked = True
bRangeEdited = False
End If
.Parent.Protect "password"
End With
End If
Xit:
End Sub
Private Sub ws_Change(ByVal Target As Range)
If Not Intersect(Range("A14:Y3000"), Target) Is Nothing Then
bRangeEdited = True
End If
End Sub
Apologies if this is simple, but I am new to VBA. I am attempting to set up the my Excel sheet so that when certain cells in the first sheet are changed (eg A1, A2, A3, A4) the names of four other sheets will change to match them. I have found the following formula which works if I change the specific cell on that sheet;
`
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Set Target = Range("A1")
If Target = "" Then Exit Sub
On Error GoTo Badname
ActiveSheet.Name = Left(Target, 31)
Exit Sub
Badname:
MsgBox "Please revise the entry in A1." & Chr(13) _
& "It appears to contain one or more " & Chr(13) _
& "illegal characters." & Chr(13)
Range("A1").Activate
End Sub
` Unfortunately it will not work if I change A1 to be dependent on one of the four cells on the main sheet specified previously, as it only looks for changes in the sheet it is saved in.
Is there a way to use VBA to look at a cell in one sheet and then change the sheet name of another sheet to match?
Thanks
Like I mentioned in the comments, it's not that simple to rename the sheet. You have to check for so many things.
My Assumptions
You have 5 Sheets in a workbook; Sheet1, Sheet2, Sheet3, Sheet4 and Sheet5
When you change cells in Sheet5, depending on the cell which changes, Sheets1-4's names are changed
I am assuming that when A1 changes, Sheet1 is renamed. When A2 changes, Sheet2 is renamed and so on...
Logic
Use Worksheet_Change event to trap changes to cell A1, A2, A3 or A4
Use Sheet CodeName to change the name
Check if the sheet name is valid. A sheet name cannot contain any of these Characters \ / * ? [ ]
Check if you already have a sheet with the name you want to use for renaming
If everything is hunky dory then go ahead and replace
Code
See this example. This code goes in the Sheet5 code area.
Dim sMsg As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsName As String
On Error GoTo Whoa
sMsg = "Success"
Application.EnableEvents = False
If Not Target.Cells.CountLarge > 1 Then
If Not Intersect(Target, Range("A1")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet1], wsName
ElseIf Not Intersect(Target, Range("A2")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet2], wsName
ElseIf Not Intersect(Target, Range("A3")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet3], wsName
ElseIf Not Intersect(Target, Range("A4")) Is Nothing Then
wsName = Left(Target, 31)
RenameSheet [Sheet4], wsName
End If
End If
MsgBox sMsg
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
'~~> Procedure actually renames the sheet
Sub RenameSheet(ws As Worksheet, sName As String)
If IsNameValid(sName) Then
If sheetExists(sName) = False Then
ws.Name = sName
Else
sMsg = "Sheet Name already exists. Please check the data"
End If
Else
sMsg = "Invalid sheet name"
End If
End Sub
'~~> Check if sheet name is valid
Function IsNameValid(sWsn As String) As Boolean
IsNameValid = True
'~~> A sheet name cannot contain any of these Characters \ / * ? [ ]
For i = 1 To Len(sWsn)
Select Case Mid(sWsn, i, 1)
Case "\", "/", "*", "?", "[", "]"
IsNameValid = False
Exit For
End Select
Next
End Function
'~~> Check if the sheet exists
Function sheetExists(sWsn As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sWsn)
On Error GoTo 0
If Not ws Is Nothing Then sheetExists = True
End Function
Screenshot