VBA Code to break list into separate emails worked on Friday - Broken today???

[bcurrey]

Backi n March I started a thread asking for VBA help that would take a list ofrepairs, break them apart based on a change in store number and paste therepairs into an Outlook email. Next, based on the store number it would look ona second tab and pull the corresponding email addresses and put them in the “To”field of the email. I made a couple of modifications, but it has workedperfectly, including when we updated to Office 365 a few weeks ago.

Today,a coworker came to me and said the macro wasn’t working. She said it’s includedall repairs in the email rather than just the repairs for that particularstore. I figured she had accidentally changed something. I tested her file andshe was correct, the system was not breaking apart the repairs by store number.Then I came to my computer to test it using the backup file I had saved. Iencountered the exact same issues. The weird part is – nothing changed in myfile over the weekend. Any ideas on why it’s not working now? Suggestions on how to fix it?

Link to prior post: https://www.mrexcel.com/forum/excel-questions/1049522-break-data-into-files-when-store-changes-prepare-email.html


Description of the file I’m using:


2 tabs in data file:

1. Tab Name: Store_Repairs
   1. Columns

Repair Ticket # ​

Customer Last Name ​

Store ​

Repair Type​

Repair Status​

Est Comp Date​

Ship Date​

Tracking Number​

Notes​

<tbody>
</tbody>

1. Tab Name: Store_info
   1. Columns

   2. StoreID ​

      State ​

      Email ​

      
      <tbody>
      </tbody>

Sub SendEmails2Mgrs()
Dim shtSrc As Worksheet, shtTarg As Worksheet
Dim vEmail, vStoreID
Dim r As Long
Dim colMgrs As New Collection
Dim vTo, vSubj, vBody
Dim oMail As Outlook.MailItem
On Error Resume Next

'Set shtSrc = ActiveSheet
Sheets("Store_Repairs").Activate

   'get uniq list of manager names
Range("C2").Select
While ActiveCell.Value <> ""
   vStoreID = ActiveCell.Value
   colMgrs.Add vStoreID, vStoreID     'add store  to list
   
   NextRow
Wend

   'now scan data pulling only recs for 1 mgr, then email it.
Range("a2").Select
r = ActiveSheet.UsedRange.Rows.Count

For Each vStoreID In colMgrs
    Range("A1").Select
    Selection.AutoFilter   'on
    ActiveSheet.Range("$A$1:$I$" & r).AutoFilter Field:=3, Criteria1:=vStoreID
    Range("A1:I" & r).Select
    Selection.Copy
       
        'paste to email
    vEmail = Application.WorksheetFunction.VLookup(vStoreID, Sheets("store_info").Range("A1:C1500"), 3)
    vTo = vEmail
    vSubj = "Store " & vStoreID & " - Daily Repair Status Update - " & Format(Now, "m-d-yy")
    vBody = "Email message goes here  " & RangetoHTML()
  
  Set olAcct = OL.Session.Accounts("My Account Name")
    
    
    
    Call Email1(vTo, vSubj, vBody)

    Selection.AutoFilter   'off
Next

Application.DisplayAlerts = True
Set colMgrs = Nothing
Exit Sub

ErrStop:
End Sub

Private Sub NextRow()
ActiveCell.Offset(1, 0).Select   'next row
End Sub

'must have reference to “Microsoft Forms 2.0 Object Library.”
'VBE (alt-F11) menu: tools, references,
Function GetClipboard()
    Dim cb As New MSForms.DataObject
   
    cb.GetFromClipboard
    GetClipboard = cb.GetText
End Function

'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE,(ALT-F11): menu,tools, references, Microsoft Outlook XX Object library
Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Const olMailItem = 0

On Error GoTo ErrMail

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With oMail
    .To = pvTo
    .Subject = pvSubj
    .HTMLBody = pvBody
''    .SentOnBehalfOfName = [EMAIL="me@me.com"]me@me.com[/EMAIL]
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
    
    .Display False
    
    .Save    'draft, we are NOT sending...we save as draft
    ''.Send
End With

Email1 = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

Function RangetoHTML() 'prng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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
    'prng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .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