Text to speech in Excel visual basic macro - vba

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

Related

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

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

Excel VBA delete entire row if cell in column D is empty

Can anyone walk me through how to write a script to delete the entire row if a cell in column D = "" on sheet 3 in range D13:D40.
Also, how to prevent the user from accidentally running the script again once those cells in the range are already deleted and other cells are now on the D13:D40 range?
Solution: This is working for me:
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("D13:D40")
With rng
' Loop through all cells of the range
' Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
' Since cell is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Explanation: Run a for loop through all cells in your Range in column D and delete the entire row if the cell value is empty. Important: When looping through rows and deleting some of them based on their content, you need to loop backwards, not forward. If you go forward and you delete a row, all subsequent rows get a different row number (-1). And if you have two empty cells next to each other, only the row of the first one will be deleted because the second one is moved one row up but the loop will continue at the next line.
No need for loops:
Sub SO()
Static alreadyRan As Integer
restart:
If Not CBool(alreadyRan) Then
With Sheets("Sheet3")
With .Range("D13:D40")
.AutoFilter 1, "="
With .SpecialCells(xlCellTypeVisible)
If .Areas.Count > 1 Then
.EntireRow.Delete
alreadyRan = alreadyRan + 1
End If
End With
End With
.AutoFilterMode = False
End With
Else
If MsgBox("procedure has already been run, do you wish to continue anyway?", vbYesNo) = vbYes Then
alreadyRan = 0
GoTo restart:
End If
End If
End Sub
Use AutoFilter to find blank cells, and then use SpecialCells to remove the results. Uses a Static variable to keep track of when the procedure has been run.
Here's my take on it. See the comments in the code for what happens along the way.
Sub deleterow()
' First declare the variables you are going to use in the sub
Dim i As Long, safety_net As Long
' Loop through the row-numbers you want to change.
For i = 13 To 40 Step 1
' While the value in the cell we are currently examining = "", we delete the row we are on
' To avoid an infinite loop, we add a "safety-net", to ensure that we never loop more than 100 times
While Worksheets("Sheet3").Range("D" & CStr(i)).Value = "" And safety_net < 100
' Delete the row of the current cell we are examining
Worksheets("Sheet3").Range("D" & CStr(i)).EntireRow.Delete
' Increase the loop-counter
safety_net = safety_net + 1
Wend
' Reset the loop-counter
safety_net = 0
' Move back to the top of the loop, incrementing i by the value specified in step. Default value is 1.
Next i
End Sub
To prevent a user from running the code by accident, I'd probably just add Option Private Module at the top of the module, and password-protect the VBA-project, but then again it's not that easy to run it by accident in the first place.
This code executes via a button on the sheet that, once run, removes the button from the worksheet so it cannot be run again.
Sub DeleteBlanks()
Dim rw As Integer, buttonID As String
buttonID = Application.Caller
For rw = 40 To 13 Step -1
If Range("D" & rw) = "" Then
Range("D" & rw).EntireRow.Delete
End If
Next rw
ActiveSheet.Buttons(buttonID).Delete
End Sub
You'll need to add a button to your spreadsheet and assign the macro to it.
There is no need for loops or filters to find the blank cells in the specified Range. The Range.SpecialCells property can be used to find any blank cells in the Range coupled with the Range.EntireRow property to delete these. To preserve the run state, the code adds a Comment to the first cell in the range. This will preserve the run state even if the Workbook is closed (assuming that it has been saved).
Sub DeleteEmpty()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet ' change this as is appropriate
Dim sourceRange As Excel.Range
Set sourceRange = ws.Range("d13:d40")
Dim cmnt As Excel.Comment
Set cmnt = sourceRange.Cells(1, 1).Comment
If Not cmnt Is Nothing Then
If cmnt.Text = "Deleted" Then
If MsgBox("Do you wish to continue with delete?", vbYesNo, "Already deleted!") = vbNo Then
Exit Sub
End If
End If
End If
Dim deletedThese As Excel.Range
On Error Resume Next
' the next line will throw an error if no blanks cells found
' hence the 'Resume Next'
Set deletedThese = sourceRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not deletedThese Is Nothing Then
deletedThese.EntireRow.Delete
End If
' for preserving run state
If cmnt Is Nothing Then Set cmnt = sourceRange.Cells(1, 1).AddComment
cmnt.Text "Deleted"
cmnt.Visible = False
End Sub
I've recently had to write something similar to this. I'm not sure that the code below is terribly professional, as it involves storing a value in cell J1 (obviously this can be changed), but it will do the job you require. I hope this helps:
Sub ColD()
Dim irow As long
Dim strCol As String
Sheets("sheet2").Activate
If Cells(1, 10) = "" Then
lrun = " Yesterday."
Else: lrun = Cells(1, 10)
End If
MsgBox "This script was last run: " & lrun & " Are you sure you wish to continue?", vbYesNo
If vbYes Then
For irow = 40 To 13 step -1
strCol = Cells(irow, 4).Value
If strCol = "" Then
Cells(irow, 4).EntireRow.Delete
End If
Next
lrun = Now()
Cells(1, 10) = lrun
Else: Exit Sub
End If
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

How do you link a time stamp to a cell using a userform button control?

Hello fellow VB Developers/Users/Hobbyists. How are You?
I have a Userform that has two buttons:
Start
Stop
When I press Start, I would like it to record the current time in the format dd/mm/yy hh:nn:ss in a specific column.
Then when I press the Stop Button I would like it to record the time again in the cell next to it.
Then if I press Start again, I would like it to record below the first cell's current record. Basically I am building a timer to record data to see how long certain tasks take.
I will post the excel file and provide more information where necessary.
Thanks for any help provided.
CURRENT CODE
Public runTimer As Double
Public startTime As Date
Dim counter As Date
Sub setStart()
counter = 0
startTime = Now
runTimer = Now + TimeSerial(0, 0, 1)
Application.OnTime runTimer, "setStart", , True
Set myTime = Sheet4.Range("F1")
Set timeRng = Sheet4.Range("C8:C100")
i = WorksheetFunction.CountA(timeRng)
i = i + 1
Cells(i, "C") = myTime
Sheet4.Cells(i, "C").NumberFormat = "yyyy/mm/dd HH:mm:ss"
If i >= 2 Then
Cells(i, "D8") = Cells(i, "C8") - Cells(i - 1, "C8")
Sheet4.Cells(i, "C").NumberFormat = "yyyy/mm/dd HH:mm:ss"
End If
Application.EnableEvents = False
End Sub
Sub setStop()
Application.OnTime runTimer, "setStop", , True
Set myTime = Sheet4.Range("F1")
Set timeRng = Sheet4.Range("D8:D100")
i = WorksheetFunction.CountA(timeRng)
i = i + 1
Application.EnableEvents = False
Cells(i, "D") = myTime
Sheet4.Cells(i, "D").NumberFormat = "yyyy/mm/dd HH:mm:ss"
End Sub
Thank you for the feedback and suggestions.
both of these work great. I am still having an issue of recording the data in specific worksheets within the code. I do not want to use the current worksheet. I would like it to be sheet1 and start the recording in cell "A8" as opposed to cell "A2"
Thanks.
I've done something similar to keep track of how long SQL and MDX queries take when run from Excel applications. Users' sense of how long something takes (it took 5 minutes!) and what actually happened don't always agree. I need to know how long certain things take to either defend the application or understand what I need to optimize.
I set up a sheet to mimic your example. The headers in row 1:
Start Time Stop Time Elapsed Time
I also have a start button and a stop button. I assigned setStart to the start button and setStop to the stop button.
The code:
Option Explicit
Sub setStart()
Dim NextRow As Long
NextRow = GetLastRow("A") + 1
With Range("a" & NextRow)
.Value = Now
.NumberFormat = "yyyy/mm/dd HH:mm:ss"
End With
End Sub
Sub setStop()
Dim NextRow As Long
NextRow = GetLastRow("B") + 1
With Range("b" & NextRow)
.Value = Now
.NumberFormat = "yyyy/mm/dd HH:mm:ss"
End With
calcElapsedTime (NextRow)
End Sub
Sub calcElapsedTime(NextRow As Long)
With Range("c" & NextRow)
.Formula = "=B" & NextRow & "-A" & NextRow
.NumberFormat = "HH:mm:ss"
End With
End Sub
Function GetLastRow(ColumnLetter As String) As Long
GetLastRow = Range(ColumnLetter & ActiveSheet.Rows.Count).End(xlUp).Row
End Function
Note that I am not checking to see if the starts and stops are done in the correct sequence. If you press start 3 times, it will continue to add values in the start column that don't have matching stop times, which will obviously foul up the elapsed times. If the code I've provided is what you're after, you'll need to add that kind of logic to your app.
I like the simplicity of #Head of Catering 's answer. You might change it slightly to a single button so that you can only start or stop depending upon which needs to occur.
You could color format the button text as well as a visual reminder.
Just a couple additions and run startTimer on CommandButton1
Option Explicit
Sub startTimer()
If ActiveSheet.CommandButton1.Caption = "START" Then
setStart
Else
setStop
End If
End Sub
Sub setStart()
Dim NextRow As Long
NextRow = GetLastRow("A") + 1
With Range("a" & NextRow)
.Value = Now
.NumberFormat = "yyyy/mm/dd HH:mm:ss"
End With
ActiveSheet.CommandButton1.Caption = "STOP"
End Sub
Sub setStop()
Dim NextRow As Long
NextRow = GetLastRow("B") + 1
With Range("b" & NextRow)
.Value = Now
.NumberFormat = "yyyy/mm/dd HH:mm:ss"
End With
calcElapsedTime (NextRow)
ActiveSheet.CommandButton1.Caption = "START"
End Sub
Sub calcElapsedTime(NextRow As Long)
With Range("c" & NextRow)
.Formula = "=B" & NextRow & "-A" & NextRow
.NumberFormat = "HH:mm:ss"
End With
End Sub
Function GetLastRow(ColumnLetter As String) As Long
GetLastRow = Range(ColumnLetter & ActiveSheet.Rows.Count).End(xlUp).Row
End Function