Worksheet_Change Event only when call value changes - excel

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

Related

How to clear cells in a column based on one cell being changed?

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

Appending text to cell but stuck in loop

My problem is that my code doesn't work how I think it should work. I have Loop in my worksheet_change macro, and in that loop I want that if statement is correct (MsgBox button pressed Yes), what is written in that cell would have appended value at the end of that text.
But if I run this macro and I press Yes - cell value has the value at the end, but MsgBox comes right again, and I'm stuck in that loop... I'm new to VBA programming and syntax.
Can someone help me and explain my mistake?
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLockable As Range
Dim cl As Range
Set rLockable = Range("C13:J1000")
Set cl = Range("C13:J1000")
Set cele = Range("K13:K1000")
vardas = ActiveWorkbook.Sheets("Login").Range("O8").Value
Select Case True
Case Not Intersect(rLockable, Target) Is Nothing
'If target is within the range then do nothing
If Intersect(rLockable, Target) Is Nothing Then Exit Sub
ActiveSheet.Unprotect Password:="1234"
For Each cl In Target
If cl.Value <> "" Then
check = MsgBox("Ar áraðyti áraðà? Koreguoti áraðo nebegalësite.", vbYesNo, "Áraðo iðsaugojimas")
If check = vbYes Then
Target.Worksheet.Unprotect Password:="1234"
cl.MergeArea.Locked = True
cl.Value = cl.Value & " " + vardas
Else
cl.Value = ""
ActiveSheet.Protect Password:="1234"
End If
End If
Exit For
Next cl
Case Not Intersect(Range("K13:K1000"), Target) Is Nothing
ActiveSheet.Unprotect Password:="1234"
For Each cele In Target
If cele.Value <> "" Then
cele.Offset(0, 2).MergeArea.Value = vardas
End If
Exit For
Next cele
End Select
ActiveSheet.Protect Password:="1234"
End Sub
Before making a change to the worksheet you need to set enableEvent to false or the worksheet_change event will kick in again.
application.enableEvents=false
'change the worksheet
application.enableEvents=true
'resets the worksheet_change event

Two Excel macros seem to conflict and prevent each other from working

I've been trying to write some macros to a cross-departmental spreadsheet, which when I press a command button will essentially "archive" a row of work. I also have one which is meant to auto-capitalise a column when people type in it. See below:
This is the Archive macro:
Sub Archive()
If MsgBox("Do you want to archive the selected row?" & vbNewLine & vbNewLine & "Row should only be archived after x has passed.", vbYesNo, "Archive") = vbNo Then Exit Sub
For Each WSheet In ActiveWorkbook.Worksheets
If WSheet.AutoFilterMode Then
If WSheet.FilterMode Then
WSheet.ShowAllData
End If
End If
For Each DTable In WSheet.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next WSheet
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim lastRow As Long
'Set variables
Set sht1 = Sheets("xDepartment")
Set sht2 = Sheets("Archive")
'Select Entire Row
Selection.EntireRow.Select
'Move row to destination sheet & Delete source row
lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
End Sub
The autocapitalisation macro is attached to the specific sheet? (i.e., it's attached when right-clicking on "xDepartment" and selecting "View code" - not sure if that has something to do with it?). There's also a macro on this sheet which calculates the date that data in a certain cell is changed:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("O:O,Q:Q,T:T,W:W")
If Not Intersect(Target, A1) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O, Q:Q"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
The error that comes up is "Run-time error '13': Type mismatch". Do you know why this might be happening?
Thanks in advance!
After your First line in the Archive macro put
Application.EnableEvents = False
On error goto Whoops
Then just above your End Sub for that macro put
Whoops:
Application.EnableEvents = True
This will turn off the other macro while your archive is running
Your code to move the row from xDepartment worksheet to Archive worksheet includes the line,
Selection.EntireRow.Select
This makes the xDepartment worksheet active. The code to actually move the row and remove the original does nothing to change the xDepartment as the ActiveSheet.
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
In your worksheet_change, you have,
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O, Q:Q"), Target)
So your Archive worksheet's Worksheet_Change is going to try to work on the xDepartment worksheet.
But you delete the row so it no longer exists; hen ce:
Run-time error '13': Type mismatch
Set your WorkRng with,
Set WorkRng = Intersect(Range("O:O, Q:Q"), Target)
It is in a private sub procedure on the Archive's private code sheet so there is no need to specify a parent worksheet unless you specifically want to work on another worksheet.
Avoid the use of ActiveSheet, Select, Selection and Activate whenever possible and never use them in a worksheet's private code sheet to refer to that worksheet.

Renaming Subs for multiple usage, Moving Rows and in VBA

I am brand new to coding.
I am trying to use the code to move rows to different sheets and to move completed rows to a different work.
I am having trouble that the Sub Worksheet_Change is being seen as ambiguous name and doesn't work when I try to change the name to something like Worksheet_ChangeCOMPLETE or WorkSheet_Change3.
Below is the codes that I am trying to use.
What my plan is that I want completed orders (rows) to move to a new workbook in which I have named "COMPLETED" when a command button is pushed which triggers a Macro to insert the word "COMPLETE" in column 13 (M).
This new workbook was formerly my sheet 2 but I made it a new workbook following instruction from another forum. I also need rows to move to sheet 3 when "PARTIAL HOLD" inserted in column 13 via a different command button and then returned to sheet one when the command button on sheet 3 "RESUME" is clicked.
All workbooks and worksheets have all the same columns and spacing, I just can't get the codes to work when I rename them.
The first set of codes I am posting are for moving rows from sheet 1 to sheet 3 when the command button is pressed, followed by the code to move rows to the new workbook these codes are in Sheet 1 under VBA project, not a module.
The third is on sheet 3 to move rows back to sheet 1 once HOLD is complete.
Thank you in advance for your help.
SHEET 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range
Set rngDest = Sheet3.Range("A5:R5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
If UCase(Target) = "PARTIAL HOLD" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_ChangeCOMPLETE(ByVal Target As Range)
Dim destWbk As String
Dim wbk As Workbook
Dim rngDestCOMPLETE As Range
destWbk = ThisWorkbook.Names("Completed.xlsx").RefersTo
destWbk = Replace(destWbk, "=" & Chr(34), "")
destWbk = Replace(destWbk, Chr(34), "")
Set wbk = Application.Workbooks(destWbk)
Set rngDest = wbk.Names("A1:S1").RefersToRange
If Not Intersect(Target, Sheet1.Range("rngTrigger")) Is Nothing Then
If UCase(Target) = "COMPLETED" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
SHEET 3
Private Sub Worksheet_Change3(ByVal Target As Range)
Dim rngDest3 As Range
Set rngDest3 = Sheet1.Range("A5:S5")
If Not Intersect(Target, Sheet3.Range("M5:M290")) Is Nothing Then
If UCase(Target) = "IN PROGRESS" Then
Application.EnableEvents = False
Target.EntireRow.Select
Selection.Cut
rngDest.Insert Shift:=xlDown
Selection.Delete
Application.EnableEvents = True
End If
End If
End Sub
As I mentioned on the comment you cannot rename these Subs, but you can do something like below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range, rngDest2 As Range, rngDest3 As Range
Dim destWbk As String
Dim wbk As Workbook
If UCase(Target.Value) = "PARTIAL HOLD" Then
Set rngDest = Sheet3.Range("A5:R5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "IN PROGRESS" Then
Set rngDest3 = Sheet1.Range("A5:S5")
If Not Intersect(Target, Sheet3.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest3.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "COMPLETED" Then
destWbk = ThisWorkbook.Names("Completed.xlsx").RefersTo
destWbk = Replace(destWbk, "=" & Chr(34), "")
destWbk = Replace(destWbk, Chr(34), "")
Set wbk = Application.Workbooks(destWbk)
Set rngDest2 = wbk.Range("A1:S1")
If Not Intersect(Target, Sheet1.Range("rngTrigger")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest2.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
End If
End Sub

Worksheet_change not working when cell content changes via VBA but does manually

I am trying to color the background of all cells in column B whose content has changed via VBA.
The background changes if I manually update the cells but not when it changes via VBA. I can not get why it is not changing with the VBA.
In the worksheet module for the sheet called OriginalData I have
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And Target <> "" Then
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
I am updating the Column 2 on OriginalData with
Sub FindReplace_Updated_UnMatched_NAMES_Original_Prepperd_2()
Dim FindValues As Variant
Dim ReplaceValues As Variant
Dim wsFR As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim lRow As Long
Dim i As Long
Sheets("Updated_UnMatched").Select
Set wsFR = ThisWorkbook.Worksheets("Updated_UnMatched")
Set wsTarget = ThisWorkbook.Worksheets("OriginalData")
lRow = wsFR.Range("C" & wsFR.Rows.Count).End(xlUp).Row
FindValues = wsFR.Range("C1:C" & lRow).Value
ReplaceValues = wsFR.Range("D1:D" & lRow).Value
With wsTarget
If IsArray(FindValues) Then
For i = 2 To UBound(FindValues)
.Columns("B:B").Replace FindValues(i, 1), ReplaceValues(i, 1), xlWhole, xlByColumns, False
Next i
Else
End If
End With
End Sub
You likely errored out on Target <> "" and got stuck with Application.EnableEvents = False environment state.
First, go to the VBE's Immediate Windows (Ctrl+G) and enter the command Application.EnableEvents = True. While in the VBE, make this modification to your code for multiple Target cell counts.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim nName As String, nEmail As String
Application.EnableEvents = False
For Each c In Target
If c.Column = 2 And c.Value <> "" Then '<~~ c <> "", not Target <> ""
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Application.EnableEvents = True
End Sub
That should be enough to get you going.
When there is some errors during event handler execution, it doesn't work properly for next times. You can find and fix the errors and it will work properly.
As a quick fix, you can do these steps:
Add On Error Resume Next at the beginning of Worksheet_Change to
prevent errors make your code stop working.
Save your workbook in a macro enabled format and reopen it enabling
active content.
Run macro and it will work properly.
I tested your code and it worked for me in Excel 2013.
It is strongly recommended to fix your errors instead of hiding them using On Error Resume Next.

Resources