Excel and Outlook become "NOT RESPONDING" when running Macro

[athishvikram]

I'm trying to run this macro below to send emails from Excel and it used to work but now it's getting stuck and making my Outlook and Excel freeze up. All it shows on the bottom of the Excel window is that it's "Saving" which I don't know why it's doing that. Can someone please help!


Sub adscallout()

'set range
Dim r As Range
Set r = Sheets("Pivot").Cells

'loop
For i = 2 To 300
ActiveSheet.Range("A1:N45").SpecialCells(xlCellTypeVisible).Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("TM").ClearAllFilters
ActiveSheet.PivotTables("PivotTable1").PivotFields("TM").CurrentPage = _
Sheet3.Range("A" & i).Value
ActiveSheet.PivotTables("PivotTable9").PivotFields("TM").ClearAllFilters
ActiveSheet.PivotTables("PivotTable9").PivotFields("TM").CurrentPage = _
Sheet3.Range("A" & i).Value
ActiveWorkbook.EnvelopeVisible = True

With r.Parent.MailEnvelope.Item
.To = Sheet3.Range("B" & i).Value
.cc = Sheet3.Range("D" & i).Value
.Subject = "WTD Quality Flash Report"
'.display
.send
End With

Next i

 

[Micron]

Did you step through this code to see where it's hanging up? First thought was that you're stuck in a loop, but I don't think that's the case. Excel might be hung up waiting for something to happen on the email (Outlook?) side of things, so look for error dialogs that are covered up and not showing. Also, this line makes no sense to me: Sheet3.Range("A" & i).Value
Should that be something = Sheet3.Range("A" & i).Value? Or Sheet3.Range("A" & i).Value = something?
Maybe your email server is balking at what it sees as a mass emailing attempt?
With this Set r = Sheets("Pivot").Cells - have you not just allocated over 17 billion cells into memory?

Please post your code within vba code tags (see vba button on posting toolbar) and use proper indentation to make your code easier for everyone to read.

 

[athishvikram]

Hi Micron,

Sorry about my ignorance, Excel Macro is very new to me hence I am not sure what the issue is ..

Did you step through this code to see where it's hanging up? - When I step in and when I run the code the email is being sent but not running one after the other just to the 1st email address.
Excel might be hung up waiting for something to happen on the email (Outlook?) side of things, so look for error dialogs that are covered up and not showing. - I did check for error dialogs but it is just stopping without any popup. Let me check again and confirm back
Maybe your email server is balking at what it sees as a mass emailing attempt? - My fellow colleagues are able to send so I think this is a issue from my end.
Also, this line makes no sense to me: Sheet3.Range("A" & i). - Is there a way to upload the excel attachment here ? I think that would give you more insight.

Please post your code within vba code tags (see vba button on posting toolbar) and use proper indentation to make your code easier for everyone to read. - Updated as requested

Sub adscallout()

'set range
Dim r As Range
Set r = Sheets("Pivot").Cells

'loop
For i = 2 To 300
   ActiveSheet.Range("A1:N45").SpecialCells(xlCellTypeVisible).Select
   ActiveSheet.PivotTables("PivotTable1").PivotFields("TM").ClearAllFilters
   ActiveSheet.PivotTables("PivotTable1").PivotFields("TM").CurrentPage = _
   Sheet3.Range("A" & i).Value
   ActiveSheet.PivotTables("PivotTable9").PivotFields("TM").ClearAllFilters
   ActiveSheet.PivotTables("PivotTable9").PivotFields("TM").CurrentPage = _
   Sheet3.Range("A" & i).Value
   ActiveWorkbook.EnvelopeVisible = True
 
   With r.Parent.MailEnvelope.Item
   .To = Sheet3.Range("B" & i).Value
   .cc = Sheet3.Range("D" & i).Value
   .Subject = "WTD Quality Flash Report"
   '.display
   .send
   End With

 

[igold]

You have responded to all the questions except this one..

Dim r As Range
Set r = Sheets("Pivot").Cells

As @Micron correctly pointed out, that one line puts every cell on the sheet into Range r. I would assume that your machine is not too happy about that. You would be better off making r a worksheet like this:

Dim r as Worksheet
set r = worksheets("Your Worksheet Name")

 

[Micron]

I was thinking more like this (which by the way makes it easier to see that CurrentPage and ClearFilters is in there 2x without any change to i, which also doesn't make sense to me):

Sub adscallout()

'set range
''Dim r As Range
Dim i As Integer
''Set r = Sheets("Pivot").Cells
'Set r = Sheets("Sheet3").Cells

'loop
For i = 2 To 300
   ActiveSheet.Range("A1:N45").SpecialCells(xlCellTypeVisible).Select
   With ActiveSheet.PivotTables("PivotTable1").PivotFields("TM")
      .ClearAllFilters
      .CurrentPage = Sheet3.Range("A" & i).Value
      .ClearAllFilters '<<why is this and the next line here 2x?
      .CurrentPage = Sheet3.Range("A" & i).Value
   End With
   
   ActiveWorkbook.EnvelopeVisible = True

   ''With r.Parent.MailEnvelope.Item
   With ActiveSheet.MailEnvelope.Item
      .To = Sheets("Sheet3").Range("B" & i).Value
      .CC = Sheets("Sheet3").Range("D" & i).Value
      .Subject = "WTD Quality Flash Report"
      '.display
      .Send
   End With
Next i

End Sub

I don't see a need for r at all if written like that but then I don't claim to have a deep grasp of Excel vba.

 

[Micron]

Sorry, forgot to address this one:

Is there a way to upload the excel attachment here ? I think that would give you more insight.

AFAIK, not here. Sometimes people will upload to a file sharing site. No guarantee that anyone will download from such sites though. I often do but some sites are just plain annoying to visit. I leave those and the file behind asap.

 

[athishvikram]

Hi Micron & igold

I did change the code but it either stopped running or I am facing with the same issue.

"'<<why is this and the next line here 2x?" - This is because there are two pivot tables that has the same source but projects different data
With this Set r = Sheets("Pivot").Cells - have you not just allocated over 17 billion cells into memory? - The Sheet name is Pivot but "ActiveSheet.Range("A1:N45"). the data goes only from these selected cells .. I believe the source of the problem is this because when I run the original code with just Range("B4").Select just to rest out then just data for 1 pivot table is being sent.

This is one code that I have but this just takes data from one pivot table .. this is running smoothly ..

Sub adscallout()

Application.ScreenUpdating = False

'set range
Dim r As Range
Set r = Sheets("pivot").Cells

'loop
For i = 2 To 200
    Range("B4").Select
    ActiveSheet.PivotTables("PivotTable2").PivotFields("user_login").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable2").PivotFields("user_login").CurrentPage = _
        Sheet3.Range("A" & i).Value
    ActiveWorkbook.EnvelopeVisible = True
 
    With r.Parent.MailEnvelope.Item
    .To = Sheet3.Range("B" & i).Value
    .Subject = "Week 5 - Speaker ID Quality Closure"
    '.display
    .send
    End With
    
Next i
   

End Sub