After some time passed using Sheet27 both events stopped working. The code for the events are on Sheet27. No other Sub is called. There are four events for Sheet27
The file is located on OneDrive and
I'm using Office365 on Windows 10 latest build. I built this app for other users who may have different Excel versions (2010 to Latest) and I'm not sure if this is going to repeat in other versions. Any light shone on this issue would be greatly appreciated.
When it stopped working I had to exit Excel entirely and reopen the file. I tried closing and reopening the file but that didn't work.
I thought it could have been the graphics card because it's a little bit older but when exiting Excel and reopening file worked, it cancelled that notion.
Maybe something along the code is causing it to stop working that I cannot see due to lack of expertise.
Maybe to do with the Excel Application or the Excel Workbook itself and not the Worksheet_Change or Worksheet_SelectionChange event because it works flawlessly when the file newly opened.
Here is Sheet27 Code: I labeled the sections that stopped working
Option Explicit
Dim RowNum As Long
Private Sub Worksheet_Change(ByVal Target As Range) 'Stopped working after some use
Application.EnableEvents = False
'This section enables and disables rows 4 through 12 via cell D3 Value of 1-10, 10 being max
'Row 3 is always shown
Select Case Range("D3").Value
Case "": Range("4:12").EntireRow.Hidden = True 'If D3 is intentionally blank
Case 1: Range("4:12").EntireRow.Hidden = True
Case 2
Rows("4:4").EntireRow.Hidden = False
Rows("5:12").EntireRow.Hidden = True
Case 3
Rows("4:5").EntireRow.Hidden = False
Rows("6:12").EntireRow.Hidden = True
Case 4
Rows("4:6").EntireRow.Hidden = False
Rows("7:12").EntireRow.Hidden = True
Case 5
Rows("4:7").EntireRow.Hidden = False
Rows("8:12").EntireRow.Hidden = True
Case 6
Rows("4:8").EntireRow.Hidden = False
Rows("9:12").EntireRow.Hidden = True
Case 7
Rows("4:9").EntireRow.Hidden = False
Rows("10:12").EntireRow.Hidden = True
Case 8
Rows("4:10").EntireRow.Hidden = False
Rows("11:12").EntireRow.Hidden = True
Case 9
Rows("4:11").EntireRow.Hidden = False
Rows("12:12").EntireRow.Hidden = True
Case 10
Rows("4:12").EntireRow.Hidden = False
Case Is > 10: MsgBox "Maximum 10 employees. If you need more than 10, add more after posting these 10.", vbInformation, "Maximum 10 Rows"
End Select
Application.EnableEvents = True
'***************************************************************
'Monthly or weekly Employee
Application.EnableEvents = False
RowNum = Target.Row
If Not Intersect(Target, Range("F3:F12")) Is Nothing Then 'Employee Name Field. Dropdown list - 10 Rows - F3:F12
'Get last row in Sheet Posting to
Range("V3").Value = Worksheets(Range("B1").Value).Range("B9999").End(xlUp).Row + 1
If Range("M" & RowNum).Value = "12" Then '12=Monthly or 52=Weekly. M3 has Index/Match formula associated to Employee Name
Range("G" & RowNum).Value = "1" 'If M3=12 then Monthly paid employee value is 1 (multiplier for monthly wage on posting Month sheet)
Else
Range("G" & RowNum & ":L" & RowNum).Value = "" 'clear associated data in G3:L3 if M3=52 (weekly paid employee)
End If
End If
Application.EnableEvents = True
'***********************************************************************
'If Loan Balance is 0 or less show warning
Application.EnableEvents = False
Dim LoanDue As Variant
Dim EmpName As String
RowNum = Target.Row
EmpName = Range("F" & RowNum).Value
LoanDue = Range("P" & RowNum).Value
If Not Intersect(Target, Range("J3:J12")) Is Nothing Then
If LoanDue < 0 Then
Target.Value = ""
Target.Select
MsgBox EmpName & "'s Loan Balance is Zero." & vbNewLine & _
"Entered payment was cleared." & vbNewLine & _
"Please notify Admin on " & EmpName & "'s record to verify or make changes.", _
vbExclamation, "Loan Payment Error"
End If
End If
Application.EnableEvents = True
End Sub
Private Sub PayDateInfoOnLbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 'This section works all the time
'Show Note
ActiveSheet.Shapes.Range(Array("TxtBxPayDate")).Visible = msoTrue
End Sub
Private Sub PayDateInfoOffLbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 'This section works all the time
'Hide Note
ActiveSheet.Shapes.Range(Array("TxtBxPayDate")).Visible = msoFalse
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Stopped working after some use
Dim VacBal As String
Dim SickBal As String
Dim EmpName As String
RowNum = Target.Row
VacBal = Range("R" & RowNum).Value 'INDEX/MATCH Formula in cell to retrieve data from EmployeeInfo sheet
SickBal = Range("T" & RowNum).Value 'INDEX/MATCH Formula in cell to retrieve data from EmployeeInfo sheet
EmpName = Range("F" & RowNum).Value
If Not Intersect(Target, Range("K3:K12")) Is Nothing Then
If VacBal = "" Then Exit Sub
MsgBox EmpName & " has " & VacBal & " Vacation Day(s) remaining.", vbInformation, "Vacation Days Balance"
End If
If Not Intersect(Target, Range("L3:L12")) Is Nothing Then
If SickBal = "" Then Exit Sub
MsgBox EmpName & " has " & SickBal & " Sick Day(s) remaining.", vbInformation, "Sick Days Balance"
End If
End Sub
Related
The below code is for VLOOKUP result in same cell, which is working well, but now I also need VLOOKUP values for Range("K:L"), (R:S) and further.
My vlookup formula is this :
nx = Application.WorksheetFunction.VLookup(batch, Sheets("Batch Card REGISTER").Range("D:E"), 2, False)
Column Index no : 2
Result I need: If i type the Qty in Cl no 10, it will verify the value from the other sheet based on the 'batch'. The column index no for all the ranges is same i.e. 2
Example: If i type 100 in Cl no 10, it will verify in the "Batch Card Register" whether the value of the mentioned batch is 100 or not. If value is not 100 i have added a code so it will return the original value which is 90.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim check
Dim cl As Range
Dim mx As Double
Dim nx As Double
Dim batch
Dim rng As Range
Dim Rg As Range
ActiveSheet.Unprotect "FGIM#22"
For Each cl In Target.Cells
If Target.Column = 10 And Target.Offset(0, -3).Value = "Product_In" Then
Application.EnableEvents = False
batch = Target.Offset(0, -6)
Set Rg = Sheets("Batch Card REGISTER").Range("D:E")
nx = Application.WorksheetFunction.VLookup(batch, Sheets("Batch Card REGISTER").Range("D:E"), 2, False)
If Target.Value And nx <> Target.Value Then
MsgBox "NOTE: Value does not Match" & VBA.Constants.vbNewLine & "Orginal Value from Batch Card Register will be Restored", vbOKOnly, "ENTRY ERROR!"
Target.Value = nx
End If
Application.EnableEvents = True
End If
Verify entry in column J when "Dispatch" in is column G
If Target.Column = 10 And Target.Offset(0, -3).Value = "Dispatch" Then
Application.EnableEvents = False
batch = Target.Offset(0, -6)
Set rng = Sheets("FG Register").Columns("D:I")
mx = Application.WorksheetFunction.VLookup(Target.Offset(0, -6), Sheets("FG Register").Columns("D:I"), 6, False)
If Target.Value And mx < 0 Then
MsgBox "Value in Current Stock cannot exceed " & mx, vbOKOnly, "ENTRY ERROR!"
Target.Value = Target.Value + mx
End If
Application.EnableEvents = True
End If
If Target.Column = 10 Then
check = MsgBox("NOTE: CANNOT be edited after confirmation, Confirm the Entry?", vbYesNo, "Confirm Entry")
If check = vbYes Then
Range("A" & cl.Row & ":J" & cl.Row).Locked = True
Else
Range("C" & cl.Row & ":H" & cl.Row).Locked = False
End If
End If
Next cl
If Not Intersect(Target, Me.Range("A1:AA1000")) Is Nothing Then
ThisWorkbook.Save
End If
End Sub
I'm very new to VBA and have been trying to code a large table which populates as changes are made to a main dashboard. It should populate each row with the date/time, user, change type, project #, old/new values, and notes on why...
I have gotten far enough to actually have this portion functioning although I am running into issues when trying to display certain rows based on criteria. For example one of my sheets displays project specific information based on the project number selected from a drop-down. Is it possible to have this also fetch all of the change log entries related to this project and display them in a table on that sheet?
Also I have a main sheet that I want to display only the last week of changes.
Here is the code I have so far:
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D10:W100")) Is Nothing Then
If Target.Count > 1 Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End
End If
If ActiveSheet.Name = "Tender-Engineering" Then
Range("U2").Value = Target.Address
Range("U6").Value = InputBox("Please provide reasoning for the proposed change.", "Notes", "Type here")
AddToLog
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("D10:W100")) Is Nothing Then
Range("U3").Value = Target.Value
Range("U4").Value = Target.Row
Range("U5").Value = Target.Column
End If
End Sub
Sub AddToLog()
Dim ActRow, Row, Column, LogRow As Long
Dim changeType As String
With Sheet4
ActRow = .Range("U2").Value
LogRow = Sheet2.Range("E9999").End(xlUp).Row + 1
Sheet2.Range("E" & LogRow).Value = Now
Sheet2.Range("F" & LogRow).Value = Application.UserName
Sheet2.Range("G" & LogRow).Value = .Range("U2").Value
Row = .Range("U4").Value
Sheet2.Range("H" & LogRow).Value = .Range("A" & Row).Value
Column = .Range("U5").Value
If Column >= 4 And Column <= 5 Then
changeType = "Management"
ElseIf Column >= 6 And Column <= 18 Then
changeType = "Schedule"
ElseIf Column >= 19 And Column <= 23 Then
changeType = "Budget"
End If
Sheet2.Range("I" & LogRow).Value = changeType
Sheet2.Range("J" & LogRow).Value = .Range("U3").Value
Sheet2.Range("K" & LogRow).Value = .Range(.Range("U2").Value).Value
Sheet2.Range("L" & LogRow).Value = .Range("U6").Value
End With
End Sub
I would like to convert the Worksheet_Change event into code that runs on demand.
The below code runs when the user make changes in the worksheet.
I want it to execute on demand.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CPTCode, EmpName As Range
Dim Cnt As Double
Set CPTCode = Range("J5:J400") ''' This is the Product Code range
Set EmpName = Range("D5") ''' This is the Emp Name focus
If Not Intersect(Target, CPTCode) Is Nothing Then
If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub
Cnt = Application.WorksheetFunction.CountIf(CPTCode, Target)
If Cnt = 4 Then
MsgBox EmpName & "You have sold " & Cnt & " Product" _
& vbNewLine & "and If you sold one more time this Product, you will get an increment.", vbInformation, "SALES RULES"
ElseIf Cnt = 5 Then
MsgBox EmpName & ", CONGRATULATIONS! you got an increment.", vbExclamation, "SALES RULES"
ElseIf Cnt > 5 Then
MsgBox EmpName & ", You cannot sale more than 5 times this product.", vbCritical, "SALES RULES"
Target.ClearContents
Target.Offset(0, -1).ClearContents
Target.Offset(0, 1).ClearContents
Target.Offset(0, -1).Select
End If
End If
End Sub
Create a new module: Insert -> Module
Paste this code into the new module:
Sub YourMacroName()
Dim CPTCode As Range, EmpName As Range
Dim Cnt As Double
Dim Target As Range
Set CPTCode = Range("J5:J400") ''' This is the Product Code range
Set EmpName = Range("D5") ''' This is the Emp Name focus
Set Target = ActiveCell
If Not Intersect(Target, CPTCode) Is Nothing Then
If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub
Cnt = Application.WorksheetFunction.CountIf(CPTCode, Target)
If Cnt = 4 Then
MsgBox EmpName & "You have sold " & Cnt & " Product" _
& vbNewLine & "and If you sold one more time this Product, you will get an increment.", vbInformation, "SALES RULES"
ElseIf Cnt = 5 Then
MsgBox EmpName & ", CONGRATULATIONS! you got an increment.", vbExclamation, "SALES RULES"
ElseIf Cnt > 5 Then
MsgBox EmpName & ", You cannot sale more than 5 times this product.", vbCritical, "SALES RULES"
Target.ClearContents
Target.Offset(0, -1).ClearContents
Target.Offset(0, 1).ClearContents
Target.Offset(0, -1).Select
End If
End If
End Sub
I made Target to refer to the ActiveCell.
I am getting an error when I am trying to capture an old value from a cell:
run-time error '13' Type mismatch.
This is the code I am using:
Dim oldValue As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target(1, 1).Value
MsgBox oldValue
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'check if one of the target columns is changed
If Target.Cells.Column = 6 Or Target.Cells.Column = 9 Or Target.Cells.Column = 10 Or Target.Cells.Column = 11 Then
'Set variables
Dim LogActivity As String
Dim cRow As Integer
Dim pRowCount As Integer
Dim wsPBS As Worksheet
Dim wsHistoric As Worksheet
Set wsPBS = Sheets("PBS")
Set wsHistoric = Sheets("Historic")
cRow = Target.Cells.Row
pRowCount = wsHistoric.Range("A" & Rows.Count).End(xlUp).Row + 1
'Check for blanks on PBS sheet and exit if entry is not complete
Dim BlankCount As Integer
BlankCount = 0
If wsPBS.Range("D" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("E" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("F" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("H" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("I" & cRow).Value = "" Then BlankCount = BlankCount + 1
If wsPBS.Range("J" & cRow).Value = "" Then BlankCount = BlankCount + 1
If BlankCount >= 1 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Target.Cells.Column = 6 Then LogActivity = "Owner change"
If Target.Cells.Column = 9 Then LogActivity = "Status change"
If Target.Cells.Column = 10 Then LogActivity = "Priority change"
If Target.Cells.Column = 11 Then LogActivity = "Completion rate"
Range("C" & cRow & ":O" & cRow).Select
Selection.Copy
wsHistoric.Select
wsHistoric.Range("F" & pRowCount).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wsHistoric.Range("A" & pRowCount).Value = Date
wsHistoric.Range("B" & pRowCount).Value = Time
wsHistoric.Range("C" & pRowCount).Value = Application.UserName
wsHistoric.Range("D" & pRowCount).Value = LogActivity
wsHistoric.Range("E" & pRowCount).Value = oldValue
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub
The value is supposed to be stored in a global dim called 'oldValue' so I can use it later on in my code.
The cell I am clicking does contain a string.
Any suggestions?
The main issue:
You're Selecting within the Worksheet_Change event.
Range("C" & cRow & ":O" & cRow).Select
Selection.Copy
That fires the Selection_Change event again, overwriting oldValue.
No need to Select here. See How to avoid using Select in Excel VBA.
Range("C" & cRow & ":O" & cRow).Copy
The secondary (yet still very important issue):
In your original version of the selection change:
Dim oldValue As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Value
End Sub
This will throw a type mismatch error if Target doesn't contain a String or something that can be coerced to a String.
In your instance, that was because Target actually was multiple cells: Range("C" & cRow & ":O" & cRow).
But your code would also throw an error if you selected a cell with an error value (#N/A, #DIV/0, etc.).
The fix:
First of all, avoid using Select, as already noted.
If for some (rare) reason you absolutely need to Select, then toggle events off and on:
Private Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
... do your stuff
Application.EnableEvents = True
End Sub
Lastly, within the selection change, instead of assuming that you'll only select a string, or only select one cell, add some validation.
Dim oldValue As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge <> 1 Then Exit Sub ' ignore a multi-cell selection
If IsError(Target.Value) Then Exit Sub ' ignore selection of errors
oldValue = Target.Value
End Sub
Try identifying a single cell withing Target:
oldValue = Target(1,1).Value
I want to create a vba code to prevent duplicate entry that also tell me the location where it is already present. E.g. in my sheet it I type 'Jimmy' in cell D13 or anywhere in column D then a MsgBox will warn me showing "The entered Name is already exists at serial number 4."
I am trying this formula but doesn't work.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Len(Target.Value) > 0 Then
If Evaluate("Countif(D:D," & Target.Address & ")") > 1 Then
MsgBox Target.Value & " is a duplicate entry. It will be removed.", vbExclamation, "Data Entry Editor" & "(INDEX(C7:C23,MATCH(target.Value,D7:D23,0))"
Range(Target.Address).ClearContents
End If
End If
End Sub
While the answer provided by #ShaiRado is certainly correct it is missing a small piece and does not point out in which line the (dupe) name exists already. So, here is another solution which includes:
the desired feature of indicating the duplicate row and
also allows for duplicates in the middle of the list. So, if you were to change in your list the name for S. No. 2 from Mukesh to
Jimmy.
Finally, the sub has been changed to allow for editing multiple cells at once (selecting several rows and pressing del or inserting several names / rows at once).
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arrList As Variant, cell As Range
Dim rowLast As Long, searchRow As Long
For Each cell In Target
If cell.Column = 4 And Trim(cell.Value2) <> vbNullString Then
rowLast = cell.Parent.Cells(cell.Parent.Rows.Count, 4).End(xlUp).Row
arrList = cell.Parent.Range("D1:D" & rowLast).Value2
For searchRow = LBound(arrList) To UBound(arrList)
If searchRow <> cell.Row Then
If arrList(UBound(arrList), 1) = arrList(searchRow, 1) Then
cell.Parent.Activate
Union(cell, cell.Parent.Range("C" & searchRow & ":F" & searchRow)).Select
MsgBox "This name exists already in row " & searchRow & _
Chr(10) & " with the S. No. " & searchRow - 6 & _
Chr(10) & Chr(10) & "This name will be now removed..."
Application.EnableEvents = False
cell.ClearContents
Application.EnableEvents = True
End If
End If
Next searchRow
End If
Next cell
End Sub
In your code you want to check for values in Column D, but in your code you are checking for If Target.Column = 2 And.. , it needs to be If Target.Column = 4.
Also, you can use the WorksheetFunction.CountIf to see if there will be duplicates in column D.
Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 And Len(Target.Value) > 0 Then
Application.EnableEvents = False
If WorksheetFunction.CountIf(Range("D:D"), Target.Value) > 1 Then
MsgBox Target.Value & " is a duplicate entry. It will be removed.", vbExclamation, "Data Entry Editor" & "(INDEX(C7:C23,MATCH(Target.Value,D7:D23,0))"
Target.ClearContents
End If
Application.EnableEvents = False
End If
End Sub
excel has this functionality built into the ribbon...
use conditional formatting - to flag the duplicates
& data validation for pop-up notification
http://www.excel-easy.com/examples/prevent-duplicate-entries.html