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.
Related
I have the following code that helps me to record multiple dates in one cell stacked however I couldnt figure out how the 2nd and further entries have the strikethrough to show that date has been changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = 1 And Target.Column = 1 Then
If Len(Target.Value) > 0 Then
Target.Offset(, 1).Value = Target.Value & _
IIf(Len(Target.Offset(, 1).Value), Chr(10), _
"") & Target.Offset(, 1).Value &
Target.Offset(, 1)
End If
End If
End Sub
If you know the length of the string that you want to NOT be strikethrough, you can use the following, replacing the 6 with your length:
With ActiveCell
With .Characters(6, Len(.Value) - (6 - 1))
.Font.Strikethrough = True
End With
End With
Without working through Terry Field's interpretation, I would never have understood your intent but there are still a few points to make.
When writing values to the worksheet within a Worksheet_Change, always suspend event handling or the event driven sub procedure will try to run on top of itself.
Whenever possible, deal with multiple Target cells rather than exiting the Worksheet_Change whenever more than a single Target is changed.
You appear to be dealing with dates in column A so use .Text rather than .Value or .Value2 in order to capture the dates as they appear on the worksheet.
This may be minor but there is no reason to .Strikethrough the vbLF so the .Strikethrough should start at the length of Target + 1 and continue to the end of the cell's displayed value.
Revised Worksheet_Change code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo meh
Application.EnableEvents = False
Dim l As Long, ol As Long, t As Range
For Each t In Intersect(Target, Range("A:A"))
If CBool(Len(t.Value2)) Then
l = Len(t.Text)
With t.Offset(0, 1)
.Value = t.Text & _
IIf(CBool(Len(.Value2)), vbLF & t.Offset(0, 1).Text, vbNullString)
.Characters(l + 1, ol).Font.Strikethrough = True
End With
t.VerticalAlignment = xlTop
End If
Next t
End If
meh:
Application.EnableEvents = True
End Sub
I am trying to make my spreadsheet autofill the corresponding cell when one of the related cells have been changed.
I have previous just defined the target as:
If Target.Address = "$A$5" then
and had no issues.
However, now my target can be one of many cells and I read that the intersect method should be able to work for this but when I input my code as:
If Intersect(Target, Range(Cells(12,2), Cells(12,j-1))) Is Nothing Then
(I am trying to change the cells below the target, with the target being any of the cells between 12B and 12(j-1) with j being previously defined)
I get the following error:
"Run-time error '1004': Application-defined or object-defined error"
But from I can tell, my code is exactly the same as all the examples around.
My full code is (although there may be an unrelated error with my vlookup as well)
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range(Cells(12, 2), Cells(12, j-1))) Is Nothing Then
If IsEmpty(Target) Then
Target.Interior.ColorIndex = 19
Else:
If Range("$A$13").Value = "" Then
Range("$A$13").Value = "Care Type"
Range("$A$13").Font.Bold = True
End If
Target.Interior.ColorIndex = xlNone
Target.Offset(1, 0).Interior.ColorIndex = 19
Target.Offset(2, 0).Value = Application.WorksheetFunction. _
VLookup(Target, Sheets("Sheet2").Range("$E$3:$F$6"), 2)
Target.Offset(2, 0).Font.Bold = True
i = 2
Do Until IsEmpty(Cells(11, i))
If Cells(11, i).Value <= ChildCount Then
Cells(12, i).Interior.ColorIndex = 19
End If
i = i + 1
Loop
End If
End If
End Sub
After using Intersect to determine that at least one cell in your range has been changed, you need to iterate through the matching cells.
Turn off event handling or the Worksheet_Change will run on top of itself when you start changing values on the worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
If not Intersect(Target, Range(Cells(12, 2), Cells(12, 11))) Is Nothing Then
on error goto safe_exit
application.enableevents = false
dim t as range
for each t in Intersect(Target, Range(Cells(12, 2), Cells(12, 11)))
If IsEmpty(t) Then
t.Interior.ColorIndex = 19
Else
If Range("$A$13").Value = "" Then
Range("$A$13").Value = "Care Type"
Range("$A$13").Font.Bold = True
End If
t.Interior.ColorIndex = xlNone
t.Offset(1, 0).Interior.ColorIndex = 19
t.Offset(2, 0).Value = Application.WorksheetFunction. _
VLookup(Target, Sheets("Sheet2").Range("$E$3:$F$6"), 2)
t.Offset(2, 0).Font.Bold = True
i = 2
'I really don't know what the following code is intended to do
'probably better as a conditional formatting rule
Do Until IsEmpty(Cells(11, i))
If Cells(11, i).Value <= ChildCount Then
Cells(12, i).Interior.ColorIndex = 19
End If
i = i + 1
Loop
End If
next t
End If
safe_exit:
application.enableevents = true
End Sub
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.
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
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.