Worksheet Change event VBA code and it crashes excel 2013 - vba

I have opened a new question after people have helped me figure out how to get my first problem fixed, now I have a new problem. You will find the coding on the "INITIATING DEVICES" page below. The idea for the second to last part of the code was to add columns (text values) from B7:b and E7:E and display it on column J7:J. So if Photo is entered into B and Pass is entered into column E then the result will be Photopass in column J. The original code works fine if run via the macro command. The problem is that I tried to add it into some of my existing code and now the whole entire program will crash when information is entered into ANY cell. The program becomes unresponsive and then it shuts down and starts up again. I don't get a code or Debug message. Here is the entire code on the page.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 7 And UCase(Target.Value) = "YES" Then
Sheets("MESSAGE CHANGES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 3).Value
Application.Goto Sheets("MESSAGE CHANGES").Cells(Rows.Count, 1).End(xlUp).Offset(, 3)
End If
If Target.Column = 6 And UCase(Target.Value) = "YES" Then
Sheets("DEVICE NOTES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 3).Value
Application.Goto Sheets("DEVICE NOTES").Cells(Rows.Count, 1).End(xlUp).Offset(, 3)
End If
'(replace if new code fails)If Target.Column = 5 And UCase(Target.Value) = "FAIL" Or Target.Column = 5 And UCase(Target.Value) = "DAMAGED" Then
'(replace if new codes fails)Sheets("FAILED DEVICES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 3) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 3).Value
If Target.Column = 5 And UCase(Target.Value) = "FAIL" Or UCase(Target.Value) = "DAMAGED" Then
Application.EnableEvents = False
Sheets("FAILED DEVICES").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 5) = Sheets("INITIATING DEVICES").Cells(Target.Row, 1).Resize(, 5).Value
Sheets("FAILED DEVICES").Cells(Rows.Count, 1).End(xlUp).Offset(, 5) = Sheets("INITIATING DEVICES").Cells(Target.Row, 11).Value
Application.EnableEvents = True
End If
'code that will place date/time when value is selcted in E
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Range("I" & Target.Row).Value = Now
End If
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("INITIATING DEVICES")
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("J7:J" & lastRow).Value = Evaluate("=B7:B" & lastRow & "&E7:E" & lastRow)
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
With Sheets("INITIATING DEVICES")
.PageSetup.PrintArea = .Range("A1:H" & .Cells(Rows.Count, 1).End(xlUp).Row).Address
End With
End Sub
Thank you for any help that you can give me, if you need anymore information I can send the inspection file and also offer more information if needed. I'm sure I messed something up and that's why it keeps crashing. Still learning here.

IF it is crashing then the Change event is being called repeatedly. You need to use
Application.EnableEvents = False
at an appropriate point to prevent the Change event being triggered again, as you make changes (with your code) to the worksheet.

Related

VBA WorkSheet_Change dont work with Template Wizard inputs

What i have in my files
A Excel Template
A Database to store the template
Both of the files are created by Template Wizard
Purpose of me using the TW is because i have to design a interactive form to send to other users for them to fill up and send it back to me and once i go into the template and save it, it will auto store it into the database that i had create in a folder at my desktop
so far the template and database transferring is working out GREAT. But i decided to do more.
Main Objective
So what i wanted to do is everytime the database updates by itself, i wanted to use the worksheet_Change function to let it auto sort by itself. So let's say if it says "Yes" at column C, i would want it to grab the whole row in the database tab and shift it to the "D" tab
And as for "No" it will shift it to "U" Tab
So i tried it on a dummy excel file and with copy and pasting it works.
BUT so i tried on the original database and the thing about template wizard is that it is not copy pasting so i dont think it works as the same like i did for manual copy and pasting.
CODE
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub
Dim cel As Range
For Each cel In Intersect(Target, Columns("C:C")).Cells
If cel.Value = "Yes" Then
With Sheets("U")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
.Range("A1:I1").Value = Rows(cel.Row).Range("A1:I1").Value
.Range("J1:AB1").Value = Rows(cel.Row).Range("AC1:AU1").Value
.Range("AC1:AE1").Value = Rows(cel.Row).Range("AV1:AX1").Value
End With
End With
ElseIf cel.Value = "No" Then
With Sheets("D")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
.Range("A1:AB1").Value = Rows(cel.Row).Range("A1:AB1").Value
.Range("AC1:AE1").Value = Rows(cel.Row).Range("AV1:AX1").Value
End With
End With
End If
Next
End Sub
Error
The error for the macro points at both
With Sheets("U")
With Sheets("D")
So if my form were to populate "Yes" The With Sheets("U") will be highlighted with error
and if i were to populate with "No" The With Sheets("D") will be highlighted with error
Might need to change Worksheet_Change to other function.. but how to make it more smart and efficient? Thanks for reading
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub
Dim cel As Range
Dim rngReceiver As Range
Dim rngDonor As Range
For Each cel In Intersect(Target, Columns("C:C")).Cells
If cel.Value = "Yes" Then
Set rngReceiver = Sheets("U").Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
rngReceiver.Resize(0, 8).Value = cel.Resize(0, 8).Value '<~ copying A:I, pasting to A1:I1
rngReceiver.Offset(0, 9).Resize(0, 18).Value = cel.Offset(0, 28).Resize(0, 18).Value '<~copying AC1:AU1 pasting to J1:AB1
rngReceiver.Offset(0, 28).Resize(0, 2).Value = cel.Offset(0, 47).Resize(0, 2).Value '<~copying AV1:AX1 pasting to AC1:AE1
ElseIf cel.Value = "No" Then
Set rngReceiver = Sheets("D").Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
rngReceiver.Resize(0, 27).Value = cel.Resize(0, 27).Value '<~ copying A1:AB1 pasting to A1:AB1
rngReceiver.Offset(0, 28).Resize(0, 2).Value = cel.Offset(0, 47).Resize(0, 2).Value '<~ copying AV1:AX1 pasting to AC1:AE1
End If
Next
End Sub
posting this answer without testing.

VBA macro run-time too long

I have written several subs which are then called from a main sub. Individual subs run very quickly, most are instantaneous (the DoFind sub takes a few seconds to run due to the large amounts of data in the table) however when I run the main sub it takes up to a minute to execute. Any ideas/tips on why this is the case?
Note, I haven't had much experience with VBA (all has been learnt in the past week). There are other macros used, but they are not shown since even the test sub takes approximately 1 minute
Sub DoFind()
Dim i As Long
i = 1
Do While Sheets("Temp").Cells(i, "A").Value <> Empty
Dim BearingArray(6) As String
BearingArray(0) = Sheets("Temp").Cells(i, "A").Value
BearingArray(1) = Sheets("Temp").Cells(i, "B").Value
BearingArray(2) = Sheets("Temp").Cells(i, "C").Value
BearingArray(3) = Sheets("Temp").Cells(i, "D").Value
BearingArray(4) = Sheets("Temp").Cells(i, "E").Value
BearingArray(5) = Sheets("Temp").Cells(i, "F").Value
BearingArray(6) = Sheets("Temp").Cells(i, "G").Value
With Sheets("Calculations")
.Cells(17, "K").Value = BearingArray(0)
.Cells(19, "O").Value = BearingArray(1)
.Cells(20, "O").Value = BearingArray(2)
.Cells(23, "O").Value = BearingArray(3)
.Cells(22, "O").Value = BearingArray(4)
.Cells(26, "O").Value = BearingArray(5)
.Cells(17, "L").Value = BearingArray(6)
End With
i = i + 1
If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then
Exit Do
Else
End If
Loop
If Sheets("Temp").Cells(i, "A").Value = Empty Then
MsgBox "No available bearing."
End If
End Sub
Sub Create_Sheet_Temp()
ThisWorkbook.Sheets.Add
ActiveSheet.Name = "Temp"
' This creates a new worksheet called "Temp"
End Sub
Sub Copy_Paste()
Dim NewTable As ListObject
Sheets("Calculations").Activate
Set NewTable = Sheets("Calculations").ListObjects("Full_Bearings_List")
NewTable.Range.SpecialCells(xlCellTypeVisible).Select
NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
Sheets("Temp").Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
'This sub copies all visible cells from a filtered table and pastes them to the new sheet called "Temp"
End Sub
Sub test()
Create_Sheet_Temp
Copy_Paste
DoFind
End Sub
You can speed up your code by storing the worksheets in variables (ahead of the loop).
Dim TempWS as Worksheet
Dim CalcWS as Worksheet
set tempws= Sheets("Temp")
set CalcWS=Sheets("Calculations")
Also declare the array outside of the loop. Also Id recommend to use numeric column index.
Sheets("Temp").Cells(i, "G").Value
to
TempWS.Cells(i, 7).Value
Comparing against Empty is not always the best choice, try
... <> ""
EDIT:
For the Copy try t use the destination parameter of the Copy method. Example from the help:
Worksheets("Sheet1").Range("A1:D4").Copy _
destination:=Worksheets("Sheet2").Range("E5")

MS Excel worksheet change event - keeping record of old cell value against new value

I'm new to this forum but have been building up my coding experience in the last couple of months due to the VBA requirements of my current role. Today's problem has seen me trawling through many sites (and my Excel VBA for Dummies book), but I haven't quite nailed it.
I am trying to make an audit tracker file in Excel for our company Risk Register. The idea is that once the risk register is established, any changes will create an audit trail (on a separate tab) which shows both the old and the new record.
I have written the code using the Change Event handler. I want my macro to fire every time there is a change and do the following:
1. Make a reference of the old cell value (what the user has just overwritten)
2. Jump to the 'Audit trail' tab and paste two copies of the full risk record - each risk record is a row of data that occupies 17 columns
3. In the first copy of these 17 columns, work out which column was edited and replace this cell with the old cell value (captured in step 1)
4. Insert a time stamp
5. Have conditional formatting highlight the record that has changed [this function is not required in the code as I've set it up within the spreadsheet itself]
6. Jump back to cell where the user just made their edit (on the 'Risk Register' tab)
I have managed steps 1, 2 and 4-7 but I am having problems getting the code to input the "old cell value" into the right spot in the 'Audit Tracker' tab. I can get it there if I manually define the cell range for it to paste into, but I can't seem to make it dynamic so that it will automatically recognize what field the user is changing and ensure the same field is amended in the audit trail.
Would really appreciate any insights as to why the "PasteRange.Value = Worksheets("Risk Register").Range("oldValuePaste")" line isn't working
My code is as follows:
Dim oldValue As Variant
Dim LastRow As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("b13:r13")) Is Nothing Then
oldValue = Target.Value
End If
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("b13:r14")) Is Nothing Then
If Target.Value <> oldValue Then
'MsgBox "You just changed " & Target.Address
Cells(65, 5).Value = oldValue 'this cell is a named range called: OldValuePaste
Cells(66, 5).Value = Target.row 'this cell is a named range called: OldValueRowNumber
Cells(67, 5).Value = Target.Column 'this cell is a named range called: OldValueColumnNumber
Range(Cells(Target.row, 2), Cells(Target.row, 18)).Copy
'Cells(70, 2).PasteSpecial xlPasteValues
Call Paste_on_AuditSheet
Sheets("Risk Register").Activate
Target.Select
Application.CutCopyMode = False
End If
End If
Application.ScreenUpdating = True
End Sub
_____________________________________________________________________________________________________
Sub Paste_on_AuditSheet()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ColNum As Long
Dim PasteRange As Range
ColNum = OldValueColumnNumber
Sheets("Audit trail").Select
'MsgBox "Activated " & ActiveSheet.Name
'Find the last used row in a Column: column B in this example
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
End With
Set PasteRange = Cells(LastRow, ColNum)
'The following two lines bring in the new data and paste into old record and new record sections:
Cells(LastRow + 1, 2).PasteSpecial xlPasteValues
Cells(LastRow + 1, 20).PasteSpecial xlPasteValues
'Then this line goes back over the piece just pasted in and changes one cell in "old record" section to what it was prior to the edit:
'PasteRange.Value = Worksheets("Risk Register").Range("oldValuePaste")
'Above line of code is not working, but can get it to do the right thing using this code (although it's not dynamic):
Range("E3").Value = Worksheets("Risk Register").Range("oldValuePaste")
'Add a time stamp:
Cells(LastRow + 1, 1) = Now
Application.ScreenUpdating = True
End Sub
One last point - despite my repeated use of Application.ScreenUpdating commands, I still get some screen flashing - any ideas why?
Thanks in advance for the help!
In reviewing your code, I saw a few things that I didn't think would work as you supposed they would, and also recognized that your code could be made much simpler and just be called from the Worksheet_Change event.
So the refactored code below and let me know if you have issues:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("b13:r14")) Is Nothing Then
'get oldValue
Dim sNewVal As String, sOldVal As String
sNewValue = Target.Value 'store current or "new" value since this is what is stored after the cell change takes place
With Application
.EnableEvents = False 'turns off event firing so the code will not go into endless loop
.Undo 'undo the change (to store old value in next line)
End With
sOldValue = Target.Value 'store old value
Target.Value = sNewValue 'reset new value
Dim lCol As Long
lCol = Target.Column 'which column of data was changed
'assumes columns A-Q are 17 columns
Me.Range(Me.Cells(Target.Row, 1), Me.Cells(Target.Row, 17)).Copy
With Sheets("Audit Trail")
Dim lRow As Long
lRow = .Range("B" & .Rows.Count).End(xlUp).Offset(1).Row
.Range("B" & lRow).PasteSpecial xlPasteValues
.Range("B" & lRow + 1).PasteSpecial xlPasteValues
.Range("A" & lRow).Value = Now
.Cells(lRow, lCol + 1).Value = sOldValue 'store old value in first pasted line ... add 1 since starting from column B
End With
End If
Application.EnableEvents = True
End Sub

How to get Excel Spreadsheet to auto populate date & time using VBA?

Trying to get a macro enabled worksheet on Excel to auto populate date and time when any values are entered in column B or C.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
For i = 2 To 100
If Cells(i, "B").Value <> " " And Cells(i, "C").Value = " " Then
Cells(i, "F").Value = Date & " " & Time
Cells(i, "F").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next
Range("F:F").EntireColumn.AutoFit
End Sub
is there anything wrong with the code I'm writing?
You don't want to run through all of that everytime anything on the worksheet changes; only when something that affects the validity of the timestamp changes. Typically, we would use Intersect to determine if one of the values that changed should receive a new timestamp. You also do not want the routine to attempt to run on top of itself so turning event handling off before changing a value (i.e. adding the time stamp) is recommended.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:C")) Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim bc As Range 'no sense in declaring something until we actually need it
For Each bc In Intersect(Target, Range("B:C")) 'deal with every cell that intersects. This is how to handle pastes into more than one cell
If Not IsEmpty(Cells(bc.Row, "B")) And Not IsEmpty(Cells(bc.Row, "C")) Then
Cells(bc.Row, "F").Value = Now 'Now is the equivalent of Date + Time
Cells(bc.Row, "F").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next bc
'Range("F:F").EntireColumn.AutoFit 'this slows things down. you may want to comment this out and just set an apprpriate column width that will handle everything
End If
SafeExit:
Application.EnableEvents = True
End Sub
That is my take on this old problem. There are many examples. Look toward the Related section down the right-hand side of this page for links to a few.
"Target" will be the cell(s) that changed. It is possible to change more then one cell at a time (via ctrl-enter) so checking all cells in the Target isn't a bad idea.
If you use the Intersect method it will get only the area of Target and the range you wanted to check that overlaps. This will then loop through those cells (if there are any) and if a value is found, timestamp them.
As others have mentioned, disabling events before you plug the stamps will prevent calling another worksheet change event. Just be careful when debugging not to leave events off.
You can read more about the event parameters here: https://msdn.microsoft.com/en-us/library/office/ff839775.aspx
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Excel.Range
Dim cll As Excel.Range
Set rng = Excel.Intersect(Target, Range("B:C"))
If Not (rng Is Nothing) Then
Excel.Application.EnableEvents = False
For Each cll In rng.Cells
If Len(cll.Formula) > 0 Then
Cells(cll.Row, 6).Value = Format$(Now, "m/d/yyyy h:mm AM/PM")
End If
Next
Range("F:F").EntireColumn.AutoFit
Excel.Application.EnableEvents = True
End If
End Sub
Couple of small changes:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Application.EnableEvents = False
If Target.Column = 2 Or Target.Column = 3 Then
For i = 2 To 100
If Cells(i, "B").Value <> " " And Cells(i, "C").Value = " " Then
Cells(i, "F").Value = Date & " " & Time
Cells(i, "F").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next
End If
Range("F:F").EntireColumn.AutoFit
Application.EnableEvents = True
End Sub
Turn the even off so you don't fire it when your code makes a modification and test the target column to see if it is B or C and only fire if it is
Also, you know your code will update rows 2 to 100 regardless of which row was changed right? If you only want the row that was changed you can get that with target.row

Excel VBA change based on pull down list

I have a few Excel formulas that change data in columns E & G based on the info entered into columns C & D. Column F needed to be a static time stamp so I had to use a simple VBA script for it. The formulas are a little long and unwieldy, and other people work on the workbook, so I tried scripting E & G through VBA to lower the risk of the formulas getting messed up.
I'm not quite the best when it comes to VBA, and after numerous failed attempts, I've ended up with what just ends up crashing Excel.
The following is my latest attempt;
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 Then
Cells(Target.Row, 6).Value = Now
End If
If Target.Column = 4 And Cells(Target.Row, 4).Value = "Daily" Then
Cells(Target.Row, 5).Value = [INDIRECT("C" & ROW())+28]
ElseIf Target.Column = 4 And Cells(Target.Row, 4).Value = "Weekly" Then
Cells(Target.Row, 5).Value = [INDIRECT("C" & ROW())+49]
Else: Cells(Target.Row, 5).Value = "---"
End If
End Sub
I also have the following which I haven't tried due to the other part crashing;
If Target.Column = 4 And (Cells(Target.Row, 4).Value = "Daily" OR Cells(Target.Row, 4).Value = "Weekly") Then
Cells(Target.Row, 7).Value = [WORKDAY(INDIRECT(""E"" & ROW()),-1]
Else Cells(Target.Row, 7).Value = "---"
End If
And the Excel formulas;
=IF(INDIRECT("D" & ROW())<>"",CHOOSE(IF(INDIRECT("D" & ROW())="Daily",1,IF(INDIRECT("D" & ROW())="Weekly",2,3)),INDIRECT("C" & ROW())+28,INDIRECT("C" & ROW())+49,"---"),"")
=IF(INDIRECT("D" & ROW())<>"",CHOOSE(IF(OR(INDIRECT("D" & ROW())="Daily",INDIRECT("D" & ROW())="Weekly"),1,2),WORKDAY(INDIRECT("E" & ROW()),-1),"---"),"")
I've tried recording a macro of the formulas and copying the code from there into the VBA code, but that didn't work either.
I said it in the title, but forgot to mention in the body; Column D is a drop down list, Column C is a date that the user enters.
Your logic is not bad, but the structure of the event macro needs improvement. For this kind of event we need:
Private Sub Worksheet_Change(ByVal Target As Range)
'if Target is NOT of interest, then exit
Application.EnableEvents = False
'perform your logic
Application.EnableEvents = True
End Sub
This prevents the macro from stepping on its own tail.
This is a better schema (untested)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 4 Then Exit Sub
Dim v As String
v = Target.Value
Application.EnableEvents = False
Target.Offset(0, 2).Value = Now
Target.Offset(0, 1).Value = "'----"
If v = "Daily" Then
'insert formula
End If
If v = "Weekly" Then
'insert formula
End If
Application.EnableEvents = True
End Sub
On a separate issue is having VBA insert a formula. Here the schema is like:
Cells(3,7).Formula="=1+2"
There may be other problems.