-
Jun 21st, 2018, 09:58 AM
#1
Thread Starter
New Member
VBA Infinite Loop in Excel.. I am guessing?
Hello, I hope this is the correct section. I am having issues after upgrading to Excel 2013. I have used this code for years however after upgrading Excel it started having issues. The Data still E-mails out correctly, then Excel hangs or loops I am guessing. I am a noob when it comes to code, I had an expert friend write it years ago and he is no longer with us. If anyone has any input that would be great and appreciated. Thanks, Chris
Windows 7
Excel 2013
Visual Basic 7.1
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 17 Then Exit Sub
If Target.Row = 5 Then
Dim rowIndex As Integer
For rowIndex = 7 To ActiveSheet.UsedRange.Rows.Count
SendMail (rowIndex)
Next
Else
SendMail (Target.Row)
End If
End Sub
Private Sub SendMail(rowIndex As Integer)
Dim cellValue As String
cellValue = Cells(rowIndex, 18)
If Cells(rowIndex, 18) = "" Or IsEmail(cellValue) = False Then Exit Sub
Dim tableHead1, tableHead2, row1, row2, row3, row4, row5, currRow As String, lawton As String
tableHead1 = "<table style='border: 1px solid black' cellspacing='0' cellpadding='0'>"
row2 = "<tr align='center'><td style='background-color: #BFBFBF;border: 1px solid black;width:100px'>DATE</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date1</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date2</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date3</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date4</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date5</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date6</td><td style='border: 1px solid black;width:100px'></td><td style='border: 1px solid black;width:100px'>@Date7</td><td style='border: 1px solid black;width:100px'></td></tr>"
row3 = "<tr align='center'><td style='border: 1px solid black'></td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>SUN</td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>MON</td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>TUE</td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>WED</td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>THU</td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>FRI</td><td style='border: 1px solid black'></td><td style='background-color: #BFBFBF;border: 1px solid black'>SAT</td><td style='border: 1px solid black'></td></tr>"
currRow = "<tr align='center'><td style='border: 1px solid black'>@Curr1</td><td style='border: 1px solid black'>@Curr2</td><td style='background-color: #BFBFBF;border: 1px solid black'>@Curr3</td><td style='border: 1px solid black'>@Curr4</td><td style='background-color: #BFBFBF;border: 1px solid black'>@Curr5</td><td style='border: 1px solid black'>@Curr6</td><td style='background-color: #BFBFBF;border: 1px solid black'>@Curr7</td><td style='border: 1px solid black'>@Curr8</td><td style='background-color: #BFBFBF;border: 1px solid black'>@Curr9</td><td style='border: 1px solid black'>@10Col</td><td style='background-color: #BFBFBF;border: 1px solid black'>@11Col</td><td style='border: 1px solid black'>@12Col</td><td style='background-color: #BFBFBF;border: 1px solid black'>@13Col</td><td style='border: 1px solid black'>@14Col</td><td style='background-color: #BFBFBF;border: 1px solid black'>@15Col</td> <td style='border: 1px solid black' colspan='2'></tr>"
lawton = "<tr><td style='border: 1px solid black'><center>NOTE:</center></td><td colspan='16' style='border: 1px solid black'>@19Col</td></tr>"
bottomMessage = "<tr><td> </td><td> </td><td colspan='16'><center>DO NOT REPLY to this message. </center></td></tr>"
tableHead2 = "</table>"
row2 = Replace(row2, "@Date1", Cells(3, 3))
row2 = Replace(row2, "@Date2", Cells(3, 5))
row2 = Replace(row2, "@Date3", Cells(3, 7))
row2 = Replace(row2, "@Date4", Cells(3, 9))
row2 = Replace(row2, "@Date5", Cells(3, 11))
row2 = Replace(row2, "@Date6", Cells(3, 13))
row2 = Replace(row2, "@Date7", Cells(3, 15))
currRow = Replace(currRow, "@Curr1", Cells(rowIndex, 1))
currRow = Replace(currRow, "@Curr2", Cells(rowIndex, 2))
currRow = Replace(currRow, "@Curr3", Cells(rowIndex, 3))
currRow = Replace(currRow, "@Curr4", Cells(rowIndex, 4))
currRow = Replace(currRow, "@Curr5", Cells(rowIndex, 5))
currRow = Replace(currRow, "@Curr6", Cells(rowIndex, 6))
currRow = Replace(currRow, "@Curr7", Cells(rowIndex, 7))
currRow = Replace(currRow, "@Curr8", Cells(rowIndex, 8))
currRow = Replace(currRow, "@Curr9", Cells(rowIndex, 9))
currRow = Replace(currRow, "@10Col", Cells(rowIndex, 10))
currRow = Replace(currRow, "@11Col", Cells(rowIndex, 11))
currRow = Replace(currRow, "@12Col", Cells(rowIndex, 12))
currRow = Replace(currRow, "@13Col", Cells(rowIndex, 13))
currRow = Replace(currRow, "@14Col", Cells(rowIndex, 14))
currRow = Replace(currRow, "@15Col", Cells(rowIndex, 15))
lawton = Replace(lawton, "@19Col", Cells(rowIndex, 19))
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mailrelay.XXX.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = Cells(rowIndex, 18)
.CC = ""
.BCC = ""
.From = "XXX@XXX.com"
.Subject = "Dates and Time"
.HTMLBody = tableHead1 + row2 + row3 + currRow + lawton + bottomMessage + tableHead2
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function IsEmail(ByVal strEmail As String) As Boolean
Dim varMailSplit As Variant
varMailSplit = Split(strEmail, "@")
If InStr(strEmail, "@") = 0 Then
IsEmail = False
Exit Function
End If
If Len(strEmail) < 18 Then
IsEmail = False
Exit Function
End If
IsEmail = True
Exit Function
End Function
-
Jun 21st, 2018, 10:15 AM
#2
Re: VBA Infinite Loop in Excel.. I am guessing?
Welcome to VBForums
Thread moved from the 'VBScript' forum to the 'Office Development/VBA' forum.
-
Jun 21st, 2018, 10:16 AM
#3
Thread Starter
New Member
Re: VBA Infinite Loop in Excel.. I am guessing?
Thank You, I think I double posted. I got click happy and did not read that it needed your approval. Thanks, Chris
-
Jun 21st, 2018, 10:19 AM
#4
Re: VBA Infinite Loop in Excel.. I am guessing?
No worries, I've already sorted the double post (it's an easy mistake to make, so happens quite a lot).
-
Jun 21st, 2018, 02:57 PM
#5
Re: VBA Infinite Loop in Excel.. I am guessing?
my first suggestion would be to put a break point in front of the line that has this:
Code:
ActiveSheet.UsedRange.Rows.Count
and see what it's value is. If it's a huge number, it could be looping a long time.
If not, maybe zip and attach the workbook with both the data (doctored up if necessary) and the code.
-
Jun 21st, 2018, 03:40 PM
#6
Thread Starter
New Member
Re: VBA Infinite Loop in Excel.. I am guessing?
Originally Posted by vbfbryce
my first suggestion would be to put a break point in front of the line that has this:
Code:
ActiveSheet.UsedRange.Rows.Count
and see what it's value is. If it's a huge number, it could be looping a long time.
If not, maybe zip and attach the workbook with both the data (doctored up if necessary) and the code.
Hello, Thank for the reply.
I think I have inserted a break point as suggested. It still freezes the Toolbar Ribbon.
I do see it will work correctly without issues in SAFE MODE.
Thanks, Chris
-
Jun 21st, 2018, 04:37 PM
#7
Re: VBA Infinite Loop in Excel.. I am guessing?
usedrange has always been a bit flakey
you should check how many rows in the usedrange
Code:
msgbox ActiveSheet.UsedRange.Rows.Count
compare that to the worksheet rows with data
how many rows would you expect to have emails to go 10? 100? 1000? more?
you can also generate some log of what emails are sent and what else is happening
if a column should have no gaps, you can use exit for on the first empty cell like
Code:
For rowIndex = 7 To ActiveSheet.UsedRange.Rows.Count
if isempty(cells(rowindex, 18)) then exit for
alternatively if there could be empty cells and you need to continue past that, try like
Code:
For rowIndex = 7 To cells(rows.count, 18).end(xlup).row
in either case change the column number to suit, 18 seemed to be the email address column
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jun 22nd, 2018, 08:15 AM
#8
Thread Starter
New Member
Re: VBA Infinite Loop in Excel.. I am guessing?
Hello, Thanks for the reply. There are gaps between columns. It is looking at up to 250 rows max. The e-mail address is located in column 18.
I have tried your code.
Code:
For rowIndex = 7 To cells(rows.count, 18).end(xlup).row
It still freezes the Toolbar Ribbon after it has ran and still works in Safe Mode. Thank You, Chris
-
Jun 22nd, 2018, 08:50 AM
#9
Re: VBA Infinite Loop in Excel.. I am guessing?
Can you zip and attach? Hard to tell what's going on without seeing it.
-
Jun 22nd, 2018, 05:39 PM
#10
Re: VBA Infinite Loop in Excel.. I am guessing?
i can not see any reason why there should be a problem, especially as it worked previously
did upgrading to 2013 include a windows veersion update as well?
can you log the sent emails to see if all are sent or some are missed?
If Cells(rowIndex, 18) = "" Or IsEmail(cellValue) = False Then Exit Sub
for test purposes at least i would change to
Code:
If IsEmail(cellValue) = False Then Exit Sub
if the cell is empty isemail should return false anyway
also, just for good measure, i would set enableevents to false in the selection change event as well as the send mail procedure
hard to test code that sends emails, without spamming
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jun 26th, 2018, 09:35 AM
#11
Thread Starter
New Member
Re: VBA Infinite Loop in Excel.. I am guessing?
Hello, Windows 7 and Office 2013 are up to date. All of the e-mail recipients are receiving the emails correctly. It works great, it just freezes the Toolbar Ribbon after it is ran. I have to save the file and close/reopen in order to for it to work again. 5 different computers.. same result.
Here is the file:
https://www.dropbox.com/s/xm6ggg87qg...dule.xlsm?dl=0
Email Example:
Thanks, Chris
Last edited by KG6KJS; Jun 26th, 2018 at 09:38 AM.
-
Jun 26th, 2018, 11:30 AM
#12
Re: VBA Infinite Loop in Excel.. I am guessing?
I can't make out what's in the image, but in the workbook I looked at, this would never process:
Code:
Dim cellvalue As String
If IsEmail(cellvalue) = False Then Exit Sub
Immediately after dimming cellvalue, you check whether or not it IsEmail. I don't see how it ever could be.
-
Jun 26th, 2018, 04:26 PM
#13
Re: VBA Infinite Loop in Excel.. I am guessing?
I don't see how it ever could be.
looks like he lost a line when editing, was originally
Dim cellValue As String
cellValue = Cells(rowIndex, 18)
If Cells(rowIndex, 18) = "" Or IsEmail(cellValue) = False Then Exit Sub
better to attach to post, zip first
if you run the code on the sample sheet, with no valid emails, does the problem still occur?
would the email addresses be in column R? which looks like phone list
i have excel 2013 on a different machine, will test later
Last edited by westconn1; Jun 26th, 2018 at 04:37 PM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jun 26th, 2018, 04:41 PM
#14
Re: VBA Infinite Loop in Excel.. I am guessing?
In the workbook referenced in Dropbox in post #11, row 7, column 18 is blank.
When looping from 7 to cells(rows.count... the first time through the loop it should hit the Exit Sub, I'd think.
-
Jun 27th, 2018, 04:40 AM
#15
Re: VBA Infinite Loop in Excel.. I am guessing?
it should hit the Exit Sub
but the loop is in the caller so it would just move to the next row and go again
All of the e-mail recipients are receiving the emails correctly
so it would appear that enableevents or something ribbon related is causing a problem, i will try to run a test shortly
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jun 27th, 2018, 05:24 AM
#16
Re: VBA Infinite Loop in Excel.. I am guessing?
on testing, with one email address, i found that the ribbon became unresponsive while the email was being sent
with multiple emails that could be quite some time
also i used doevents to make sure i could break out of any endless loop, but it was not required
i would suggest some log to work out how long the emails take to send, compare that to the time the ribbon is unresponsive
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jun 27th, 2018, 07:50 AM
#17
Re: VBA Infinite Loop in Excel.. I am guessing?
but the loop is in the caller so it would just move to the next row and go again
I should look at the code more carefully before posting.
-
Jul 5th, 2018, 12:15 PM
#18
Thread Starter
New Member
Re: VBA Infinite Loop in Excel.. I am guessing?
Hello, Thanks for the the reply's
I used the code below this week. All 189 employees received the e-mail within a few minutes after batching out.
if you run the code on the sample sheet, with no valid emails, does the problem still occur?
Yes, if I run the code with non valid e-mails the problem still occurs.
would the email addresses be in column R? which looks like phone list
Yes the first attached spreadsheet Column "R" is were the e-mail address is listed.
In the second attached spreadsheet below Column "S" is were the e-mail address is listed.
i would suggest some log to work out how long the emails take to send, compare that to the time the ribbon is unresponsive
The mail server log is not showing errors, it is sending all 195 e-mails (Some Employees have multiple addresses) from Excel within 19 seconds.
Excel has not shown me any errors besides freezing the Ribbon.
I have left Excel to run after batching out to see if the Ribbon will unfreeze... or become responsive again... it was still frozen 36 hours later.
I have been working around the issue by saving before batch, then close/reopen after batch.
It works in Safe-Mode with zero issues.
Current Code, used last week:
Code:
Private Sub worksheet_selectionchange(ByVal Target As Range)
If Target.Column <> 18 Then Exit Sub
If Target.Row = 5 Then
Dim rowIndex As Integer
For rowIndex = 7 To ActiveSheet.UsedRange.Rows.Count
Sendmail (rowIndex)
Next
Else
Sendmail (Target.Row)
End If
End Sub
Private Sub Sendmail(rowIndex As Integer)
Dim cellvalue As String
cellvalue = Cells(rowIndex, 19)
If Cells(rowIndex, 19) = "" Or IsEmail(cellvalue) = False Then Exit Sub
Dim TableHead1, TableHead2, row2, row3, currRow As String, row4 As String
TableHead1 = "<table style='border: 1px solid black' cellspacing='0' cellpadding='0'>"
row2 = "<tr align='center'><td style='background-color: #BFBFBF;border: 1px solid black;width:100px'>DATE</td><td style='border: 1px solid black;width:100px'>@Date1</td><td style='border: 1px solid black;width:100px'>@Date2</td><td style='border: 1px solid black;width:100px'>@Date3</td><td style='border: 1px solid black;width:100px'>@Date4</td><td style='border: 1px solid black;width:100px'>@Date5</td><td style='border: 1px solid black;width:100px'>@Date6</td><td style='border: 1px solid black;width:100px'>@Date7</td>"
row3 = "<tr align='center'><td style='border: 1px solid black'>#@Curr2</td><td style='background-color: #BFBFBF;border: 1px solid black'>SUN</td><td style='background-color: #BFBFBF;border: 1px solid black'>MON</td><td style='background-color: #BFBFBF;border: 1px solid black'>TUES</td><td style='background-color: #BFBFBF;border: 1px solid black'>WED</td><td style='background-color: #BFBFBF;border: 1px solid black'>THUR</td><td style='background-color: #BFBFBF;border: 1px solid black'>FRI</td><td style='background-color: #BFBFBF;border: 1px solid black'>SAT</td>"
currRow = "<tr align='center'><td style='border: 1px solid black'>@Curr1</td><td style='border: 1px solid black'>@Curr4</td><td style='border: 1px solid black'>@Curr6</td><td style='border: 1px solid black'>@Curr8</td><td style='border: 1px solid black'>@10Col</td><td style='border: 1px solid black'>@12Col</td><td style='border: 1px solid black'>@14Col</td><td style='border: 1px solid black'>@16Col</td>"
row4 = "<tr align='center'><td style='border: 1px solid black'>NOTE:</td><td colspan='16' style='border: 1px solid black'>@20Col</td></tr>"
bottomMessage = "<tr align='center'><td colspan='16' style='border: 1px solid black'>DO NOT REPLY to this message.</td></tr>"
TableHead2 = "</table>"
row2 = Replace(row2, "@Date1", Cells(3, 4))
row2 = Replace(row2, "@Date2", Cells(3, 6))
row2 = Replace(row2, "@Date3", Cells(3, 8))
row2 = Replace(row2, "@Date4", Cells(3, 10))
row2 = Replace(row2, "@Date5", Cells(3, 12))
row2 = Replace(row2, "@Date6", Cells(3, 14))
row2 = Replace(row2, "@Date7", Cells(3, 16))
row3 = Replace(row3, "@Curr2", Cells(rowIndex, 3))
currRow = Replace(currRow, "@Curr1", Cells(rowIndex, 1))
currRow = Replace(currRow, "@Curr4", Cells(rowIndex, 4))
currRow = Replace(currRow, "@Curr6", Cells(rowIndex, 6))
currRow = Replace(currRow, "@Curr8", Cells(rowIndex, 8))
currRow = Replace(currRow, "@10Col", Cells(rowIndex, 10))
currRow = Replace(currRow, "@12Col", Cells(rowIndex, 12))
currRow = Replace(currRow, "@14Col", Cells(rowIndex, 14))
currRow = Replace(currRow, "@16Col", Cells(rowIndex, 16))
row4 = Replace(row4, "@20Col", Cells(rowIndex, 20))
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxx.xxx.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = Cells(rowIndex, 19)
.CC = ""
.BCC = ""
.from = "xxx@xxx.com"
.Subject = "Schedule"
.HTMLBody = TableHead1 + row2 + row3 + currRow + row4 + bottomMessage + TableHead2
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function IsEmail(ByVal strEmail As String) As Boolean
Dim varMailSplit As Variant
varMailSplit = Split(strEmail, "@")
If InStr(strEmail, "@") = 0 Then
IsEmail = False
Exit Function
End If
If Len(strEmail) < 10 Then
IsEmail = False
Exit Function
End If
IsEmail = True
Exit Function
End Function
Spreadsheet Used Last Week:
https://www.dropbox.com/s/kq0zm5l75q...20V2.xlsm?dl=0
Example E-Mail Body from this version:
https://www.dropbox.com/s/x93pclcm4w...0Body.PNG?dl=0
Thanks, Chris
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|