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
Related
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
In my code I use a Workbook_BeforeSave function that does some text formatting.
When I hit the Save button, it runs and formats the size and font type of some cells.
Here is part of my code that does the job:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim c As Range
Dim rng As Range
Set rng = ActiveSheet.UsedRange.Cells
For Each c In rng
If ispcname(c.Value) = True Or isip(c.Value) = True Then ActiveSheet.Hyperlinks.Add Anchor:=c, Address:="": c.HorizontalAlignment = xlCenter: c = StrConv(c, vbProperCase): c.Font.Name = "Arial": c.Font.Size = "10"
If Right(c, 1) = "$" Then
y = c.Column: x = c.Row
Dim i As Integer
For i = 1 To rng.Rows.Count
If LCase(Cells(i, y).Value) = "backup" Then
If Right(c, 1) = "$" Then Cells(x, y) = Cells(x, y - 2) & "$": ActiveSheet.Hyperlinks.Add Anchor:=c, Address:="": c.Font.Name = "Calibri": c.Font.Size = "10": c.HorizontalAlignment = xlCenter: c.Font.Color = RGB(192, 0, 0)
End If
Next i
End If
Next c
End Sub
I have recently implemented a code that will save the Workbook if it is closed.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub
Then something went wrong that I can't explain. When ActiveWorkbook.Save runs, the cells that should change into Calibri, change into Arial instead, size remains unmodified, color is working normally. However when I manually hit the save button it works as it should. (changes the cells back to Calibri)
There is no other code interfering because when I commented out the part that changes the font type to Calibri, the ActiveWorkbook.Save also stopped changing it into Arial as well.
My questions are:
Why is this happening? Is this a bug?
Is there any workaround?
I am using Excel 2007.
Not sure why this is happening at all, but one workaround seems to be calling Workbook_BeforeSave manually and then disabling it for the ActiveWorkbook.Save call:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Application.EnableEvents = False
Workbook_BeforeSave False, False 'Manual call.
Me.Save 'Save without the event firing again.
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
That said, you also have some curious logic in the Workbook_BeforeSave handler. First, I don't think that For i = 1 To rng.Rows.Count is doing what you think it's doing. It isn't necessarily going to loop over the entire column, because UsedRange.Cells doesn't have to start at row 1. If your used range is something like $A$4:$Z$100, rng.Rows.Count will be 97 and all of your references to Cells(i, y) would be off by 3.
It also isn't clear if ispcname(c.Value) = True Or isip(c.Value) = True and Right(c, 1) = "$" are mutually exclusive. If they are, If Right(c, 1) = "$" should actually be an ElseIf.
Couple other things:
Executing 5 different statements in a one line If statement is
incredibly hard to read and that makes it error prone. Use actual
If...End If blocks unless the action is something trivial like
Exit Sub.
The second If Right(c, 1) = "$" Then is always true.
It can be removed completely.
After actually formatting your code in
a readable way, it's clear that you are using properties of c all
over the place inside the For Each c In rng loop. I'd put it in a
With block.
You only need to use ActiveSheet once. After that,
you can either get it from rng.Parent or (much better) get a
reference to it.
Get in the habit of using String returning
functions instead of Variant returning functions when you need a
String. I.e. Right$ instead of Right - the latter performs an
implicit cast.
Fully qualify all of your references to Cells.
Avoid implicitly using the default properties of objects, i.e. Range.Value.
Use Long for row counters, not Integer to avoid the possibility for overflows.
Use vbNullString instead of the literal "".
Font.Size is measured in points. It should be a number, not a string.
It should look more like this:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim c As Range
Dim sh As Worksheet
Set sh = ActiveSheet 'Tip 4
Dim rng As Range
Set rng = sh.UsedRange.Cells
For Each c In rng
With c 'Tip 3
If ispcname(.Value) Or isip(.Value) Then 'Tip 1
sh.Hyperlinks.Add Anchor:=c, Address:=vbNullString 'Tips 4 and 9
.HorizontalAlignment = xlCenter
.Value = StrConv(.Value, vbProperCase) 'Tip 7
.Font.Name = "Arial"
.Font.Size = 10 'Tip 10
End If 'Pretty sure this should be an ElseIf structure here.
If Right$(.Value, 1) = "$" Then 'Tips 5 and 7.
y = .Column
x = .Row
Dim i As Long 'Tip 8
For i = 1 To rng.Rows.Count 'This is most likely wrong.
'Tip 2 used to be here.
If LCase$(sh.Cells(i, y).Value) = "backup" Then 'Tips 1, 5, and 6
.Value = sh.Cells(x, y - 2).Value & "$" 'Tips 4, 6, and 7
sh.Hyperlinks.Add Anchor:=c, Address:=vbNullString 'Tips 4 and 9
.Font.Name = "Calibri"
.Font.Size = 10 'Tip 10
.HorizontalAlignment = xlCenter
.Font.Color = RGB(192, 0, 0)
End If
Next i
End If
End With
Next c
End Sub
If you are using "$" to say that the cell is a currency, don't test if the last character is "$". you have to check if the cell has a currency format.
Modify the line
if right(c,1)= "$"
to
fc = c.NumberFormat
If InStr(1, c, "$") = 0 Then ...
your test will never find the "$" in c.
Basically, I have a rather large (and growing) sheet of position details and I'm looking to build in a sub routine that, once a position number is entered into the relevant cell, will auto-populate the corresponding cells in the row. VLOOKUP would do the trick nicely except, when a position has multiple lines, it returns the earliest set of details--I need it to return the latest.
I can produce the answer I need using a LOOKUP function , but I can't seem to translate the function across to VBA.
Example lookup function:
LOOKUP(D17,1/($D$2:$D$10=D17),E2:E10)
This is what I have so far
Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 4 Then
actionrow = Target.Row
resulte = Application.WorksheetFunction.Lookup(2, 1 / Range("D2:D10") = Target.Value, Range("E2:E10"))
If Target.Value <> "" Then
Range("E" & actionrow).formula = resulte
End If
End If
End Sub
I think that looking at column D for a matching value with the Range.Find method would do. Start at the Target cell and use the SearchDirection:=xlPrevious option. Something will always be found. If the row it is found is not the same row as Target then use the value in column E to populate the cell right of Target.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Columns(4), Target) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = True
Dim trgt As Range, lastrw As Long
For Each trgt In Intersect(Columns(4), Target)
lastrw = Columns(4).Find(what:=trgt.Value, after:=trgt, _
lookat:=xlWhole, SearchDirection:=xlPrevious).Row
Debug.Print lastrw
If lastrw <> trgt.Row Then
trgt.Offset(0, 1) = Cells(lastrw, trgt.Column + 1).Value
End If
Next trgt
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
This should survive pasting multiple values into column D.
You can use .Find function with parameter SearchDirection:=xlPrevious
For case where you are searching word "AC" in a row 4:
Set FindCell = sh_wb_SF.Range("4:4").Find(What:="AC", LookIn:=xlValues, SearchDirection:=xlPrevious)
If FindCell Is Nothing Then
MsgBox ("Ooooooopppps")
End If
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 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.