How to get Excel Spreadsheet to auto populate date & time using VBA? - 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

Related

Strikethrough to the custom VBA

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

Excel VBA: How to create macro to change text color using if statement

This is a continuation for the following question: What is the cause for Conditional Formatting to get jumbled up?
In an attempt to prevent my conditional formatting from going haywire, I decided to convert it into code in VBA. I decided to start small and start with converting one conditional formatting into VBA.
Explanation:
In column O there are a series of numbers, obtained from a different sheet. User inputs number in column F. For example if number in F9 is less than O9, the font colour will become red. If not number remains normal. The formula should start at row 9 and can continue down onwards and should be automatic.
Meaning the moment a number is keyed in column F the font colour should change instantly.
The following is the code I created so far:
Sub change_color()
With Me.Range("f9", Range("f" & Rows.Count).End(xlUp)) 'so the formula will carry onwards from f9 onwards
If f9 < o9 Then
Range(f).Font.Color = vbRed
End If
End With
End Sub
But alas it didn't work. I also tried linking it to a button and nothing happens. And I also remember to remove my old conditional formatting as well. Is there something I'm missing?
You are after something like the code below.
This code is to be ran once, it will lopp through the entire column "F" in your worksheet, and change the font of all instances.
Regular Module Code
Option Explicit
Sub change_color()
Dim LastRow As Long, i As Long
With Worksheets("Sheet1") ' modify to your sheet's name
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 1 To LastRow
If .Range("F" & i).Value < .Range("O" & i).Value Then
.Range("F" & i).Font.Color = vbRed
Else
.Range("F" & i).Font.Color = vbBlack
End If
Next i
End With
End Sub
To "catch" the modification in real-time, when someone changes a value in column "F", and then change the font according to the criteria you specified, you need add the following code to the Worksheet module, where you have your data, and add the piece of code below to Worksheet_Change event.
Code in Sheet1 module (modify to your sheet's)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 6 Then ' if someone changes a value in column "F"
Application.EnableEvents = False
If Target.Value < Range("O" & Target.Row).Value Then
Target.Font.Color = vbRed
Else
Target.Font.Color = vbBlack
End If
End If
Application.EnableEvents = True
End Sub
Does this work for you?
Option explicit
Sub ChangeColor()
With thisworkbook.worksheets(YOURSHEETNAME) 'Replace with sheet name as per your workbook.'
Dim LastRow as long
Lastrow = .cells(.rows.count,"F").end(xlup).row
Dim RowIndex as long
For rowindex = 9 to LastRow
If .cells(rowindex,"F").value2 < .cells(rowindex,"O").value2 then
.cells(rowindex,"F").font.color = vbred
End if
Next rowindex
End With
End Sub

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

Concatenating values in target column

I'm having troubles with a VBA code: There's an Excel sheet (Sheet1) that contains two essential columns (last & first name)
What I am trying to do is, that whenever you add another last and first name to the list, both of them automatically get concatenated in another sheet and form a new list (start position for that list is Sheet11.Range("AB3"), on position AB2 is the list title "Clients").
My code therefore was entered in Sheet1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tmp As Range
For Each tmp In Sheet1.Range("C4:C100")
If tmp.Value <> "" And tmp.Offset(0, 1).Value <> "" Then
Sheet11.Cells(Cells(Rows.Count, "AB").End(xlUp).Row + 1, "AB").Value = tmp.Value & " " & tmp.Offset(0, 1).Value
End If
Next tmp
End Sub
Unfortunately, as soon as I enter first & last names while this code is active, the concatenated names are not listed one after another, but the last name in the list replaces the list title in AB2.
I guess the problem lies somewhere within the loop process, but I can't seem to figure out the logic behind it. I'd be thankful for any suggestions to solve that problem!
The problem is that the following instruction
Sheet11.Cells(Cells(Rows.Count, "AB").End(xlUp).Row + 1, "AB").Value
returns the same cell each time the loop is repeated. You can replace this whole line for example by this:
Range("AB" & tmp.Row).Value = tmp.Value & " " & tmp.Offset(0, 1).Value
Whenever you use a Worksheet_Change event macro to change the values of cell on the same worksheet, you need to turn off event handling or the value change will trigger a new event and the Worksheet_Change will try to run on top of itself. This also holds true for other worksheets that contain a Worksheet_Change unless you want the change in value to force the event. Similarly, the Target can represent more than a single cell (e.g. a paste operation) so you need to deal with the individual cells in the Intersect, not the Intersect as a whole.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B:C")) Is Nothing Then
On Error GoTo bm_Safe_exit
Application.EnableEvents = False
Dim bc As Range
For Each bc In Intersect(Target, Columns("B:C"))
Sheet11.Cells(bc.Row, "AB") = _
Join(Array(Cells(bc.Row, "B").Value2, Cells(bc.Row, "C").Value2))
Next bc
End If
bm_Safe_exit:
Application.EnableEvents = True
End Sub
I've used the Join Function as the string concatenation mechanism. While any character can be supplied as a connector in a Join, the default is a space.
I suggest a faster Change event - you don't need to loop over all rows for every update
This will add new entries and update existing ones:
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .CountLarge = 1 And .Row >= 3 And (.Column = 3 Or .Column = 4) Then
Dim cel As Range
Set cel = Cells(.Row, 3)
If Len(cel) > 0 And Len(cel.Offset(0, 1)) > 0 Then
Worksheets("Sheet11").Range("AB" & .Row) = cel & " " & cel.Offset(0, 1)
End If
End If
End With
End Sub

Text to speech in Excel visual basic macro

I've been trying to write a macro in excel that can recognize changing values of a column of cells and trigger an alert using text to speech for the corresponding row different column. Below are two sets of code I've used and have produced results, however I need to finetune the code as I've run into a few obstacles:
the first code updates too frequently (each time there is an external update to the sheet, fires off this code).
Sub Worksheet_Calculate()
Dim myText As String
For Each c In Range("bf4:bf45")
If c.Value = 1 Then
myText = c.Offset(0, -57).Text
Application.Speech.Speak (myText)
End If
Next
End Sub
the second code fires off only when I manually hit the enter key in the range defined.
Sub worksheet_change(ByVal target As Range)
If target = 1 And _
target.Column = 58 And _
target.Row >= 4 And _
target.Row <= 45 Then _
Application.Speech.Speak target.Offset(0, -57).Text
End Sub
I am trying to add code that can either provide a timer for this code ( so every 4 minutes the text to speech alert will go off) or each time the defined column's values change there will be an auto text to speech alert of corresponding row.
Thanks!
Edited to include code of worksheet calculate and code for .ontime
Sub Worksheet_Calculate()
Dim myText As String
For Each c In Range("bf4:bf45")
If c.Value = 1 Then
myText = c.Offset(0, -57).Text
Application.Speech.Speak (myText)
End If
Next
End Sub
Public Sub Updatetextspeech()
'Clock that prompts running of text to speech alert
Sheets("ALERTS").Select
Call myText
Nexttick = Now + TimeValue("00:03:00")
Application.OnTime Nexttick, "Updatetextspeech"
If Time >= TimeValue("16:00:00") Then
Application.OnTime Nexttick, "Updatetextspeech", , False
End If
End Sub
Additional code updated 9/12/2014 in response to DavidZemens code
Option Explicit
Dim oldValues As Variant
Dim rng As Range
Sub Main()
'## Define our range to monitor, modify as needed
Set rng = Sheets("ALERTS").Range("be4:be45")
'## Store its values in the array
oldValues = rng.Value
'## Initialize the UpdateTextSpeech
' I use a shorter interval for debugging, modify as needed
Application.OnTime Now + TimeValue("00:00:10"), "UpdateTextSpeech"
End Sub
For some reason below section of the code sub "updatetextspeech" is causing alot of breaks, of the different code I tried I would either get object not defined, or compile errors, or argument not optional below are the few different codes for the application.speech I tried
Sub UpdateTextSpeech()
Dim r As Long
**'## Iterate the range**
For r = 1 To rng.Rows.Count
'Check if its value has changed AND the adjacent cell
If rng.Cells(r, 1).Value <> oldValues(r, 1) And rng.Cells(r, 1).Offset(0, 1).Value = 1 Then
**'This is where your speech app goes:**
Application.speech.speak.cells(r,1).text 'OR
Application.speech.speak.value.text 'OR
Application.speech.speak (updatetextspeech).text 'OR
End If
Next
'Provide a way to escape the OnTime loop:
If MsgBox("Continue monitoring cell changes?", vbYesNo) = vbYes Then
'update the "old" values
oldValues = rng.Value
Application.OnTime Now + TimeValue("00:00:10"), "Updatetextspeech"
End If
End Sub
Let's try something like this.
First, declare a module-level variable to represent the range of cells you want to monitor, and also their values can be stored as a module level variant.
We'll initially store the values. Then we start our timer loop using Application.OnTime method. Each interval we will compare the current values to the values stored at the last interval. If the value has changed and if the formula equals 1, then you can do the speech. A prompt will ask the user if s/he wants to continue. If yes, then we store the new values in the variant and those will be compared against the next interval.
I use a shorter interval, and a message box instead of the speech application, but you should be able to modify this.
Option Explicit
Dim oldValues As Variant
Dim rng As Range
Sub Main()
'## Define our range to monitor, modify as needed
Set rng = Sheets("ALERTS").Range("A2:A10")
'## Store its values in the array
oldValues = rng.Value
'## Initialize the UpdateTextSpeech
' I use a shorter interval for debugging, modify as needed
Application.OnTime Now + TimeValue("00:00:10"), "UpdateTextSpeech"
End Sub
Sub UpdateTextSpeech()
Dim r As Long
'## Iterate the range
For r = 1 To rng.Rows.Count
'Check if its value has changed AND the adjacent cell
If rng.Cells(r, 1).Value <> oldValues(r, 1) And rng.Cells(r, 1).Offset(0, 1).Value = 1 Then
'This is where your speech app goes:
MsgBox rng.Cells(r, 1).Address & " has changed." & vbCrLf & vbCrLf & _
"Old value: " & oldValues(r, 1) & vbCrLf & _
"New value: " & rng.Cells(r, 1).Value
End If
Next
'Provide a way to escape the OnTime loop:
If MsgBox("Continue monitoring cell changes?", vbYesNo) = vbYes Then
'update the "old" values
oldValues = rng.Value
Application.OnTime Now + TimeValue("00:00:10"), "Updatetextspeech"
End If
End Sub