VBA to automatically fill in a template, then email

[moyay4]

Hi, I am very new to VBA but can follow the basic logic fairly well.

I have a list of people on sheet 1, column A. The corresponding information for each person is listed across 5 columns in sheet B (cols A:E). **The row numbers are consistent throughout the sheets (ie. Joe is listed in Row 5 on sheet 1, and his name and info is listed in Row 5 cols A:E on sheet 2).

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]June Sales[/TD]
[TD]Sales Quota[/TD]
[TD]YTD Sales[/TD]
[TD]Total June Payout[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]$5000[/TD]
[TD]$3000[/TD]
[TD]$20,000[/TD]
[TD]$4,000[/TD]
[/TR]
[TR]
[TD]Susan[/TD]
[TD]$4500[/TD]
[TD]$3500[/TD]
[TD]$21,000[/TD]
[TD]$4,000[/TD]
[/TR]
</tbody>[/TABLE]


What I want to do is to customize this weekly report for each person: Joe gets only HIS information emailed to him in a "template" that would be standard for each person (see below) -- the template would be the words in blue with the corresponding info, and this would be put directly into the BODY of the email
[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]June Sales[/TD]
[TD]Sales Quota[/TD]
[TD]YTD Sales[/TD]
[TD]Total June Payout[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]$5000[/TD]
[TD]$3000[/TD]
[TD]$20,000[/TD]
[TD]$4,000[/TD]
[/TR]
</tbody>[/TABLE]

This would be repeated for all people on the list (100+). I think I can figure out some email code, but it is getting the information into the SAME template for each person repeatedly (not sure how to write a loop for this including the template)

Thank you so much for any help you can offer!!!!!

 

[Smitty]

Welcome to the Board!

If Outlook is your e-mail client, then take a look at Ron DeBruin's Mail from Excel and make/mail PDF files (Windows). He's got just about all the HTML mail code you could ever want. Specifically look at the Mail Range or Selection and Mail a different file(s) to each person in a range.

I'd imagine that you'd want to loop through the list of recipients, use AutoFilter to filter down to just their data, then create the Message/Mail Body. If you PM me your e-mail address I'll send you an example that I just put together for someone this week.

 

[moyay4]

I figured I would also post this publicly.

This is what I have so far. I am having trouble with my "For Each...Next" constructs. I keep getting a compile error. Also, I am not sure how to use the Autofilter function.

Option Explicit


Sub SendEMail()
'   Sends an E-Mail notification
'   This will copy the Personnel Details to the body of the e-mail
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lr As Long
    Dim rngDetails As Range
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim tmpMsg As String
    Dim cell As Range
    Dim Filecell As Range
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Set ws = Sheets("Personnel")
    Set ws1 = Sheets("Details")
    
    lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
   
    
    On Error Resume Next
        
        For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        Set rngDetails = ws1.Range("A1:L" & lr)
        
            If cell.Value Like "?*@?*.?*" And _
                Application.WorksheetFunction.CountA(rngDetails) > 0 Then
                Set OutMail = OutApp.CreateItem(0)
             
        
                With OutMail
                    .To = "cell.Value" ' You can loop through the Personnel list here if you have a list of e-mails
                    .CC = ""
                    .BCC = ""
                    .Subject = "TD Request: " & Format(Date, "mm/dd/yy")
                    
                        tmpMsg = "Please find the attached Technical Director Request for the following event: " & "

" & _
                            "Event Name:                 " & "       " & ws.Range("D2") & "
" & _
                            "Event Location:            " & "   " & ws.Range("N9") & ", " & ws.Range("E2") & "
" & _
                            "Event Start Date:          " & " " & Format(ws.Range("G2"), "mm/dd/yy") & "
" & _
                            "Personnel Details:      " & "
"
                            
            End If
            
                    .HTMLBody = tmpMsg & RangetoHTML(rngDetails)
                    .Attachments.Add ActiveWorkbook.FullName
                
                    .Display
                    
            
                 End With
    On Error GoTo 0


    Set OutMail = Nothing
    Set OutApp = Nothing
    Set ws = Nothing
    
End Sub


Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function