Cancel macro 1 if macro 2 is running - excel

I have two macros altogether, one macro assigned to my Private Worksheet_Change event and the other assigned to my Private Worksheet_SelectionChange event like so:
Macro 1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If Hours Column Selected
If Not Intersect(Target, Range("Z" & ActiveCell.Row)) Is Nothing And Range("Z" & ActiveCell.Row).Value <> "" Then
NewValue = Application.InputBox("Please Enter Your Delegated Reference:")
If NewValue <> vbNullString Then
Dim rw2 As Long, cell2 As Range
rw2 = ActiveCell.Row
With Worksheets("Data").Columns("I:I")
Set cell2 = .find(What:=NewValue, LookIn:=xlFormulas, _
LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not cell2 Is Nothing Then
Application.DisplayAlerts = False
cell2.Offset(0, 4).Value = Sheet1.Range("Y" & ActiveCell.Row).Value
cell2.Offset(0, 5).Value = Sheet1.Range("H" & ActiveCell.Row).Value
cell2.Offset(0, 6).Value = Sheet1.Range("I" & ActiveCell.Row).Value
MsgBox "Found"
Sheet1.Range("Y" & ActiveCell.Row).Value = cell2.Offset(0, 1).Value
Sheet1.Range("H" & ActiveCell.Row).Value = cell2.Offset(0, 2).Value
Sheet1.Range("I" & ActiveCell.Row).Value = cell2.Offset(0, 3).Value
Application.DisplayAlerts = True
Else
MsgBox "Not Found"
Sheet1.Range("A5").Select
End If
End With
Else
If NewValue = vbNullString Then
MsgBox "Not Found"
Sheet1.Range("A5").Select
End If
End If
End If
End Sub
Macro 2
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("Y" & ActiveCell.Row)) Is Nothing Then
myValue3 = MsgBox("This is a message")
End If
End Sub
The problem I have is when I click on my active cell row in column Z I am running macro 1 and asking it to update the value of my active cell row in column Y. However when the information in column Y is updated, it is causing macro 2 to run where I get a msgbox displaying and I don't want this to happen.
Whilst I still require macro 2 and do want the msgbox to display, I only want it to display when I click on the cell in column Y. So in other words, I want to be able to cancel out macro 2 if macro 1 is running.
I have tried using application.displayevents = false in macro 1 but this doesn't work.
Please can someone show me the best way to do this?

you can use
Application.EnableEvents = False
.. at the start of your macro1 to disable events and
Application.EnableEvents = True
To turn it back on again at the end of macro1.

Please try the following:
[1] Add a new Module to your VBA Project, with the following:
Public EventRunning as Boolean
[2] Modify your Worksheet_SelectionChange macro as follows:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
EventRunning=True
...
EventRunning=False
End Sub
[3] Modify your Worksheet_Change as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If EventRunning Then Exit Sub
...
Best wishes Ben

Related

Remember the previous value of formulas

After a deep research on the internet I managed to find a VBA code that allows me to remember the previous result of a formula. I would like to modify this code to obtain the previous value of the formulas in one column in another column next to it.
For example: if '' B2: B80 "contains formulas, I would like" D2: D80 "to show the previous value of those formulas.
The code that I show does not keep the previous values ​​in a single cell but continuously populates a column down and my goal is to obtain the previous value of each formula in a single cell, but of several cells of a column.
Dim xVal As String
Private Sub Worksheet_Change(ByVal Target As Range)
Static xCount As Integer
Application.EnableEvents = False
If Target.Address = Range("C2").Address Then
Range("D2").Offset(xCount, 0).Value = xVal
xCount = xCount + 1
Else
If xVal <> Range("C2").Value Then
Range("D2").Offset(xCount, 0).Value = xVal
xCount = xCount + 1
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
xVal = Range("C2").Value
End Sub
Please try this simple code. I think it will do what you want.
Sub CopyValues()
With Worksheets("Sheet1") ' enter your tab's name here
.Range("B2:B80").Copy
.Cells(2, "D").PasteSpecial xlValues
End With
Application.CutCopyMode = False
End Sub
i use something similar to track changes on another sheet. Maybe this will help?
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim sSheetName As String
sSheetName = "Data"
If ActiveSheet.Name <> "LogDetails" Then
Application.EnableEvents = False
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " - " & Target.Address(0, 0)
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = oldValue
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
Sheets("LogDetails").Columns("A:E").AutoFit
Application.EnableEvents = True
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo ErrHandler:
n = 1 / 0
Debug.Print n
oldValue = Target.Value
oldAddress = Target.Address
Exit Sub
ErrHandler:
n = 1
' go back to the line following the error
Resume Next
oldValue = Target.Value
oldAddress = Target.Address
End Sub
This tracks each change made in all sheets bar the LogDetails so would record all your changes.
I believe if you add the last sub into yours and change the reference it should work.

Prevent EventChange Sub running unexpectedly

Advice would be gratefully appreciated. I am developing a spreadsheet using Excel 2016/Windows.
I have written 4 eventchange subroutines and all work well. The VBA Code for a worksheet checks for 4 events. Event 1, 2 and 3 enter today's date in a cell if data is entered in another cell (code not included below)
Code for EventChange works fine, but sometimes works when not expected to!
EventChange4 moves a value from one cell to another if another cell contains the text in Column J is "THIS Month – Payment Due" or "Issued But Not Paid. The second part of this eventchange4 moves a zero value to 2 cells if the data in column j contains text "not going ahead"
I am new to VBA. The problem is that eventchange4 runs for no apparent reason, e.g. copying a cell value in column H down to another cell in column h. How can I modify the code such that that eventchange4 only runs when the data in Column J Changes??? All advice gratefully accepted!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Call EventChange_1(Target)
Call EventChange_2(Target)
Call EventChange_3(Target)
Call EventChange_4(Target)
End Sub
Sub EventChange_1(ByVal Target As Range)
'Update on 11/11/2019 -If data changes in column L, insert
'today's date into column M
End Sub
Sub EventChange_2(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column P, insert today's date
'into next Column Q
End Sub
Sub EventChange_3(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column R, insert today's date
'into next Column S
End Sub
Sub EventChange_4(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
' this works !
If Target.Column = 10 And (Target.Value = "THIS Month – Payment Due" Or Target.Value = "Issued But Not Paid") Then
Range("K" & Target.Row).Value = Range("I" & Target.Row).Value
Range("I" & Target.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If Target.Column = 10 And (Target.Value = "Not Going Ahead") Then
Range("I" & Target.Row).Value = 0
Range("K" & Target.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Application.EnableEvents = True
End Sub
Ideally you should update your code so it can properly handle a Target range which is not just a single cell:
Sub EventChange_4(ByVal Target As Range)
Dim rng As Range, c As Range, v
'any part of Target in Column J?
Set rng = Application.Intersect(Target, Me.Columns(10))
If Not rng Is Nothing Then
'have some cells to process...
On Error GoTo haveError
Application.EnableEvents = False
'process each affected cell in Col J
For Each c In rng.Cells
v = c.Value
If v = "THIS Month – Payment Due" Or v = "Issued But Not Paid" Then
Range("K" & c.Row).Value = Range("I" & c.Row).Value
Range("I" & c.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If v = "Not Going Ahead" Then
Range("I" & c.Row).Value = 0
Range("K" & c.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Next c
End If
haveError:
Application.EnableEvents = True
End Sub
NOTE: this is assumed to be in the relevant worksheet code module - otherwise you should qualify the Range() calls with a specific worksheet reference.
All your "change" handlers should follow a similar pattern.
Tim apologies. I am new to this and was anxious to get a solution. Thank you for your response. Advice Noted. T
When I attempt to insert or delete a row in the spreadsheet, the VBA code identifies a worksheet event and attempts to run the code. The spreadsheet crashes. I have attempted to add code that will prevent this by checking at the beginning of the module if a row has been inserted or deleted before the other worksheet change event if statements are checked
Thank you
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim wsInc As Worksheet
Dim count As Integer
Dim lRow As Long
Dim ans As Variant
Dim tb As ListObject
On Error GoTo Whoa
Application.EnableEvents = False
Set tb = ActiveSheet.ListObjects(1)
MsgBox Target.Rows.count
If tb.Range.Cells.count > count Then
count = tb.Range.Cells.count
' GoTo Whoa
ElseIf tb.Range.Cells.count < count Then
count = tb.Range.Cells.count
' GoTo Whoa
'~~> Check if the change happened in Col A
ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'~~> Check if the change happened in Col L
ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
Set wsInc = Sheets("Income")
lRow = wsInc.Range("A" & wsInc.Rows.count).End(xlUp).Row + 1
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~> Check of the value is Fees Received, Policy No. Issued
If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If ans = False Then Exit For
wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
End If
End If
End With
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub

Excel vba - Disable paste in multiple cells

I am writing code which compares date entered in one column to date in another column. An error message is displayed if the entry violates data validation rules.
Also, I have disabled cut-paste operation and ctl+d.
Data Validation rules:
Enter valid date between 01/01/1900 and 12/31/9999
Date value in Column AP should be greater than Column AO.
But, when a user copies a cell, selects multiple cells in the target column and pastes, then data validation doesn't trigger at all. Below is the screenshot:
The below code handles single cell operations like copying a cell and paste in another cell but not able to handle when a user selects more than one cell and pastes.
Please help me understand as what is wrong with my code. Thank you!
Here is my code:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler
Dim lstrow As Long
lstrow = Range("A" & Rows.Count).End(xlUp).Row
If Intersect(Target, Range("AP5:AP" & lstrow - 1)) Is Nothing Then Exit Sub
If Target.Value <> "" And Target.Value <= Range("AO" & Target.Row) Then
Application.EnableEvents = False
Target.Value = ""
MsgBox ("The date you have entered is either not in correct format OR less than date in column AO")
Else: Target.NumberFormat = "dd-mmm-yyyy"
End If
ErrorExit:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Sub
I tried the below code but it didn't work.
if Target.cells.count > 1 then
msgbox("Select a single cell to paste")
ActiveCell.Select
end if
'========================================================================
I have encountered another issue. Now, I want to evaluate one more column in the same worksheet under worksheet_change event. But, code for only one column is getting evaluated and not the other column.
Please advise.
Here is my updated code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Added to define the last row by locating the text string (blank)
On Error GoTo ErrorHandler
Dim lstrow As Long
'ActiveRow = ActiveCell.Row
lstrow = Range("A" & Rows.Count).End(xlUp).Row
If Intersect(Target, Range("AP5:AP" & lstrow)) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
Application.Undo
MsgBox "Select only single cell to paste"
ActiveCell.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
End If
If Target.Value <> "" And Target.Value <= Range("AO" & Target.Row) Then
Application.EnableEvents = False
Target.Value = ""
MsgBox ("The date you have entered is either not in correct format OR less than Column AO")
Else: Target.NumberFormat = "dd-mmm-yyyy"
Application.EnableEvents = True
Exit Sub
End If
'----------------------------------------------------------------------------------
If Intersect(Target, Range("AL5:AL" & lstrow)) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
Application.Undo
MsgBox "Select only single cell to paste"
ActiveCell.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
End If
If Target.Value <> "" And Target.Value <= Range("AK" & Target.Row) Then
Application.EnableEvents = False
Target.Value = ""
MsgBox ("The value you entered is less than the value in column AK")
Else: Target.NumberFormat = "0.00"
Application.EnableEvents = True
Exit Sub
End If
'----------------------------------------------------------------------------------
ErrorExit:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Sub
Can we evaluate two different ranges in the same worksheet_change event?
screenshot of the worksheet after the code is run:
After the line
If Intersect(Target, Range("AP5:AP" & lstrow - 1)) Is Nothing Then Exit Sub
Try inserting this additional checking:
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
Application.Undo
msgBox "entering many cells simultaneously in column AP is not allowed"
Application.EnableEvents = True
Exit Sub
End If

Excel VBA delete row dont execute vba script

Good day, i got a set of code as below:
Dim oval
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oval = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C2:C1048576")) Is Nothing Then
Range("G" & Target.Row) = Now()
Range("H" & Target.Row) = oval
End If
End Sub
This is supposed to update column "G" with current date and time while column "H" with previous content in "C" should a change detected in column "C".
While this code is working, i got an issue whereby deleting a row of data in the middle of the table will shift the lower row up to the deleted row but it will update the column "G" and "H" as well.
is there a way to prevent that? thank you.
This will solve some of your problems:
Dim oval
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
oval = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2:C1048576")) Is Nothing Then
Application.EnableEvents = False
Range("G" & Target.Row) = Now()
Range("H" & Target.Row) = oval
Application.EnableEvents = True
End If
End Sub
I would get rid of the public variable and Worksheet_SelectionChange event macro. Application.Undo can be applied within the Worksheet_Change event macro after recording the changed values.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim rng As Range, vCEEs As Variant
vCEEs = Range(Cells(1, "C"), Cells(Rows.Count, "C").End(xlUp)).Value
Application.Undo
For Each rng In Intersect(Target, Range("C:C"))
Range("G" & rng.Row) = Now()
Range("H" & rng.Row) = Range("C" & rng.Row)
Range("C" & rng.Row) = vCEEs(rng.Row, 1)
Next rng
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
This should survive pasting multiple values into column C but you risk losing values pasted into other columns.

How do I block/clear data for each cell in a column that matches the conditional if statement in VBA?

I am new to VBA programming in excel and would like to know how to do the following (I have searched google and will post what I have tried here with sample code).
Column G, starting at G11 continuing to the end of the sheet, contains 2 values: either "Full Time" or "Part Time".
In column S, starting at S11 continuing until the end of the sheet, our accountant will enter a Dollar value. The Accountant wants the excel cell in Column G to block/clear out any data and have a popup message saying that "You cannot edit this Cell in Column G as the employee is Part Time".
I used this code, but it only works for Row 11. I would like this to work for every row in Column G. Do you have any pointers or tips? Thanks in advance.
I use the 2 events Change and SelectionChange
Private Sub Worksheet_Change(ByVal Target As Range)
If [$G11] = "Part Time" Then
[$S11].Interior.ColorIndex = 34
[$S11].ClearContents
[$S11].Locked = True
Else
[$S11].Interior.ColorIndex = 12
[$S11].Locked = False
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If [$G11] = "Part Time" Then
[$S11].ClearContents
[$S11].Locked = True
Else
[$S11].Locked = False
End If
End Sub
Try this out. I made some assumptions based on what you wrote, so if it doesn't quite fit your data, let me know.
Private Sub Worksheet_Change(ByVal Target As range)
If Not Intersect(Target, .Columns("S:S")) Is Nothing Then 'only do this if column S is changed
Application.EnableEvents = False
If range("G" & Target.Row) = "Part Time" Then
With range("S" & Target.Row)
.Interior.ColorIndex = 34
.ClearContents
.Locked = True
End With
Else
With range("S" & Target.Row)
.Interior.ColorIndex = 12
.Locked = False
End With
End If
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As range)
If Not Intersect(Target, .Columns("S:S")) Is Nothing Then 'only do this if column S is changed
Application.EnableEvents = False
If range("G" & Target.Row) = "Part Time" Then
With range("S" & Target.Row)
.ClearContents
.Locked = True
End With
Else
range("S" & Target.Row).Locked = False
End If
Application.EnableEvents = True
End If
End Sub

Resources