Odd macro looping issue

[mattmickle]

I've just recently upgraded from Excel 2007 to Office 365.
I've written a macro that creates unique reports for a list of recipients (store numbers), looping through until the last and popping up a message box to tell me it's complete.
Here's the code:

Sub CREATE_LIST()
'
' PHARMACY COURSE NOTIFICATION STORES LIST
' Macro written 07/09/2013 by Matthew Mickle

'
    Application.DisplayAlerts = False
    
    'counter = 1
    
    Set srange = ActiveWorkbook.Worksheets("Store_Notifications").Range("H3").Cells
    
    For Each aname In ActiveWorkbook.Worksheets("Store_Notifications").Range(srange).Cells
    
    Sheets("Store_Notifications").Activate
    Range("N2").Select
    ActiveCell.FormulaR1C1 = aname
    
    'counter = counter + 1
    
    'MsgBox "Report " & counter
    
    Call Mail_Store
    
    Next

'Sheets("Email").Activate

MsgBox "The Pharmacy Course Notification Reports have been sent."

'Call PHARM_NOTIFICATION

End Sub

The code works...the problem is that it seems to shut down after building approximately 1/2 of the reports and sending them. It doesn't error out, it just ignores the last 30 or so of the 60 reports I'm creating, even popping up the "I'm complete" message when finished. No error, no debugging, just ignoring part of the variable srange.

The code works (creates all 60 of the reports) IF i activate the counter lines and press OK in between each report, but that almost defeats the purpose of the macro.

Any ideas?

[Norie]

Where's the rest of the code, specifically the sub Mail_Store?

[mattmickle]

The Mail_Store code is an alteration of Ron DeBruin's code for creating a "snapshot" of data within an excel spreadsheet and pasting it into the body of an email. I've used this for several other projects with no issues (prior to conversion to Office 365).

Sub Mail_Store()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim TBody As String
    Dim UBody As String

    'Page range for selection
    Set prange = ActiveWorkbook.Worksheets("Store_Notifications").Range("H7").Cells

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Sheets("Store_Notifications").Range(prange).SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    
    Set srange = ActiveWorkbook.Worksheets("Email").Range("M5").Cells
    
    TBody = Sheets("Email").Range("I2").Value & "<br><br>" & _
            Sheets("Email").Range("I3").Value & Sheets("Email").Range("I4").Value
            
    
    UBody = "<br>" & Sheets("Email").Range("J2").Value & "<br>" & _
            Sheets("Email").Range("J3").Value & "<br>" & _
            Sheets("Email").Range("J4").Value & "<br>" & _
            Sheets("Email").Range("J5").Value & "<br>" & _
            Sheets("Email").Range("J6").Value & "<br>" & _
            Sheets("Email").Range("J7").Value & "<br>" & _
            Sheets("Email").Range("J8").Value & "<br>" & _
            Sheets("Email").Range("J9").Value & "<br>" & _
            Sheets("Email").Range("J10").Value & "<br><br>" & _
            Sheets("Email").Range("J11").Value
            
            

    For Each scount In ActiveWorkbook.Worksheets("Email").Range(srange).Cells
        
      With OutMail
           
        .To = ActiveWorkbook.Worksheets("Email").Range("D" & scount).Cells
        .CC = ActiveWorkbook.Worksheets("Email").Range("E" & scount).Cells & "; " & ActiveWorkbook.Worksheets("Email").Range("F" & scount).Cells & "; " & ActiveWorkbook.Worksheets("Email").Range("G" & scount).Cells
        .Subject = ActiveWorkbook.Worksheets("Email").Range("H" & scount).Cells
        .HTMLBody = TBody & RangetoHTML(rng) & "<br>" & UBody
        
        .Send
        
        
      End With
       
Next

    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing



End Sub


Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

[mattmickle]

Norie? Any ideas? I'm stumped.
I've even taken this exact code and run it in Excel 2007 with no issues. Something in either Excel 2013 or Outlook 2013 is partially blocking the sending of the emails. I'm hoping this is just some sort of configuration that can be changed...

I've got this posted over on mrexcel.com also, but no response...

[Arkadi]

mattmickle, when you activate the counter and have to hit ok, you are basically building in a delay between iterations of the loop. I don't know why you are getting problems, but have you tried just putting a delay in where the message box would come up with the counter? Not ideal, but maybe worth at least testing? If it works then at least you know it is a timing issue, and can move on from there... Something like

Application.Wait (Now + TimeSerial(0, 0, 2))

which would wait 2 seconds for each loop?

[mattmickle]

Arkadi,
One of the first things I tried. Didn't work. I went as far as 10 seconds with no success. I'm really stumped by this one...

[Arkadi]

I see that throughout Ron's code there is On Error Resume Next, and On Error Goto 0, which as you may know disables or ignores error checking. Have you tried commenting those out just to see if you get errors THEN? If you do, you may get some insight into what is happening if the problem lies in the mail_store sub

[mattmickle]

Unfortunately, tried that too. There's nothing wrong with the code. It's not erroring out. No debugger comes up. My computer is simply pretending that the last 30 or so variables in my range don't exist. My thought is something in Outlook 365 is blocking the mailings.