Break data into files when store # changes & prepare email

[bcurrey]

Hello. I’m hoping someone can assist or point me to a solution to what I’m looking for. Below is an example layout of my datasets.

I have a spreadsheet with 2 tabs. The first tab has a list of all repairs that are in the building. The second tab, has all the store email addresses. My goal is to be able to quickly prepare daily repair update summaries to send to the stores.

I have macros built that will refresh these datasets when the user presses the “Refresh” button. I want to add a second button that allows will do the following:

1. Break each store’s data into their own file, including line 1 with the column headers, (Orders on tab 1 are always sorted by Store#) and save the file as the Store# and current date.
2. Next, the VBA would open an email in Outlook, look at tab 2 and find the correct store email address based on the store number.
   1. The email doesn’t need to send. I just want it to be able to prepare the draft.

There’s about 90 different stores in a given day that will receive one of these emails. I’m open to any suggestions or changes as long as I get to the end solution of being able to send the stores daily updates. Let me know if this is possible or if something like this has been done somewhere else. I appreciate the help! Thx!




Tab 1: Repairs

Order #	Store #	Date	Status	Location	Desc
987654	S123	1/1/18	Backorder	Memphis	Replace Chip
987435	S123	2/1/18	Backorder	Detroit	Replace Button
897235	S123	3/1/18	Backorder	Atlanta	Replace Glass
156832	S100	3/3/18	Backorder	Dallas	Replace cover

<tbody>
</tbody>

Tab 2: Store_Info

Store#	State	Email
S100	AL	Saban@alabama.com
S123	FL	Mickey@disney.com; Goofy@disney.com; Donald@asurion.com <tbody> </tbody>
S200	WA	seahawks@seattle.com; washington@seattle.com <tbody> </tbody>

<tbody>
</tbody>

 

[ranman256]

run: sendEmail2Mgrs

it scans the list of stores, then emails each (draft) with their data.

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


On Error Resume Next


'Set shtSrc = ActiveSheet
sheets("Repairs").activate


   'get uniq list of manager names
Range("B2").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:$F$" & r).AutoFilter Field:=2, Criteria1:=vStoreID
    Range("A1:F" & r).Select
    Selection.Copy
       
        'paste to email
    vEmail = Application.WorksheetFunction.VLookup(vStoreID, Sheets("store_info").Range("A1:C50"), 3)
    vTo = vEmail
    vSubj = "your data"
    vBody = RangetoHTML()
    
    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
    
    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, , 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