Add name from spreadsheet to email text

S

spudulene

New member
Joined
Aug 20, 2019
Messages
20
Reaction score
0
Points
1
Excel Version(s)
Excel 2019
Each month, my office sends out a excel spreadsheet to each employee with their spending for the month. This is done with a VBA script. I inherited the code, do not have access to the individual who wrote it, and have almost zero experience with VBA. I have been able to update the email text some. However, I would like to personalize each email by including the individual’s first name after “Hello,” so it starts “Hello <Fname>,” I think I should be able to include the fist name from a column in the Dist spreadsheet (highlighted in yellow). I have no idea how to code this. Can anyone help? As always, I appreciate your time.

View attachment guru-email-vba.xlsm
 
If you are not opposed to using a different example :

Code: 
Option Explicit

Sub Send_Email()


    Dim c As Range
    Dim strBody As String
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
    On Error Resume Next
    
    
    For Each c In Range("G2:G100")
    strBody = "Greetings : " & c.Offset(0, -6).Value & "<br></br><br></br>" _
                & c.Offset(0, -2).Value & "<br></br><br></br><br></br>" _
                & "Sincerely, " & "<br></br><br></br>" _
                & "Your Signature Here"
                
    
        If c.Value <> "" Then
            Set OutLookApp = CreateObject("Outlook.application")
            Set OutLookMailItem = OutLookApp.CreateItem(0)
            With OutLookMailItem
                    .To = c.Offset(0, -5).Value
                    .CC = c.Offset(0, -4).Value
                    .Subject = c.Offset(0, -3).Value
                    .HTMLBody = strBody   'c.Offset(0, -2).Value
                    .Attachments.Add c.Offset(0, -1).Value
                    .Display
                    '.Send
            End With
        End If
    Next c


End Sub


Sub clrSend()
    Range("G2:G100").Value = ""
End Sub
 

Attachments

  • Multi Emails.xlsm
    19.9 KB · Views: 7
I appreciate the effort. But, I was hoping not to have to start from scratch. I do not know how to integrate this with the extraction of the individual sheets that I already have. If I use this code and spreadsheet it looks like I would have to create the individual excel files first so that I could link each to the emails.
 
I did try to run the code from the file you attached but it did not send any email messages to my Outbox, nor did it give me any errors when I clicked the button. It just did nothing. I did make sure the macro was on.
 
In the following segment of code :

Code: 
.HTMLBody = strBody   'c.Offset(0, -2).Value                    
.Attachments.Add c.Offset(0, -1).Value
                    .Display
                    '.Send

Place a hyphen in front of .Display ... and remove the hyphen from in front of '.Send ...

Those two lines will look like this :

' .Display
.Send


Also ... no some computers it might be necessary to have Outlook running in the background.
 
Is there anyone who can help me by just adding a column of names in the speadsheet and then adjusting code that I already have? I have almost zero experience coding with VBA and the option that I was presented was not what I was looking for. Thank you.
 
Ok.. I looked at this, and to make the change you want, you need to change 3 procedures...

Add a variable (Facename as string) to each of the buttons, and then to the Mail_Sheet procedure.

I tried to attached the spreadsheet with the changes, but it won't upload, so here is the code:

Code: 
Private Sub Send_S_Email_Click()


    Dim Facsheet As String
    Dim Facemail As String
    Dim Facename As String
    
        Facsheet = Cells(5, 5)
        Facemail = Cells(5, 6)
        Facename = Cells(5, 7)
        Call Module1.Mail_Sheet(Facsheet, Facemail, Facename)
End Sub
Code: 
Private Sub SendEmails_Click()


    Dim Facsheet As String
    Dim Facemail As String
    Dim Facename As String
    Dim rownumb As Integer
    
    rownumb = 4
    
    Do Until Cells(rownumb, 1) = "END"
    
        Facsheet = Cells(rownumb, 1)
        Facemail = Cells(rownumb, 2)
        Facename = Cells(rownumb, 3)
        Call Module1.Mail_Sheet(Facsheet, Facemail, Facename)
        rownumb = rownumb + 1
        
    Loop
    
    With Range("E1")
        .Value = Date
        .NumberFormat = "mm/dd/yy"
    End With

End Sub
Code: 
Public Sub Mail_Sheet(ssheet As String, semail As String, sname As String)
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String


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


    Set Sourcewb = ActiveWorkbook
    
    Application.Wait (Now + TimeValue("00:00:05"))


    'Copy the ActiveSheet to a new workbook
    'ActiveSheet.Copy
    Sheets(ssheet).Copy
    Set Destwb = ActiveWorkbook


    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            'Select Case Sourcewb.FileFormat
            'Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            'Case 52:
            '    If .HasVBProject Then
            '        FileExtStr = ".xlsm": FileFormatNum = 52
            '    Else
            '        FileExtStr = ".xlsx": FileFormatNum = 51
            '    End If
            'Case 56: FileExtStr = ".xls": FileFormatNum = 56
            'Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            'End Select
            FileExtStr = ".xlsx": FileFormatNum = 51
        End If
    End With


    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = ssheet & " Budget Update " & Format(Now, "yymmdd h-mm-ss")


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    strbody = "Hello, " & sname & ",<br><br>" & _
        "Attached is an Excel file listing your department fund holdings to date. It includes all information we currently have, but may not list recent pcard charges that have not been reconciled/approved.<br>" & _
        "Please reivew the entries in the spreadsheet for errors." & _
        "If you have any questions please contact Christine.<br><br>Thanks,<br>KC"
    


    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .Display
            .to = semail
            .CC = ""
            .BCC = ""
            .Subject = "Department Budget Update"
            .HTMLBody = strbody & "<br>" & .HTMLBody
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr


    Set OutMail = Nothing
    Set OutApp = Nothing


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


I've tested it, and it works so far.
 
You must log in or register to reply here.
Back
Top