Results 1 to 2 of 2

Thread: Excel VBA - email content of cell on each row (not a fixed cell)

  1. #1
    VBAX Regular
    Feb 2018

    Excel VBA - email content of cell on each row (not a fixed cell)

    Hi, I'm having difficulty with a VBA code, which I need to amend. It fires of an email with the details in each row of an excel spreadsheet (to the email in A1)

    I need the subject to always be the contents of cell E (each row will be different) and the body of the text is address to the contents of cell B2, the date in the body is always cell C, and amount in the body is always contents of cell D.

    Each row will be different, so the email needs to pull the details from each row, rather than a fixed cell.

    Your help is much appreciated

    Sub Send_Row_Or_Rows_1()
    'For Tips see:
    'Don't forget to copy the function RangetoHTML in the module.
    'Working in Excel 2000-2016
        Dim OutApp As Object
        Dim OutMail As Object
        Dim rng As Range
        Dim Ash As Worksheet
        Dim Cws As Worksheet
        Dim Rcount As Long
        Dim Rnum As Long
        Dim FilterRange As Range
        Dim FieldNum As Integer
        Dim mailAddress As String
        On Error GoTo cleanup
        Set OutApp = CreateObject("Outlook.Application")
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        'Set filter sheet, you can also use Sheets("MySheet")
        Set Ash = ActiveSheet
        'Set filter range and filter column (Column with names)
        Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
        FieldNum = 1    'Filter column = A because the filter range start in A
        'Add a worksheet for the unique list and copy the unique list in A1
        Set Cws = Worksheets.Add
        FilterRange.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=Cws.Range("A1"), _
                CriteriaRange:="", Unique:=True
        'Count of the unique values + the header cell
        Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
        'If there are unique values start the loop
        If Rcount >= 2 Then
            For Rnum = 2 To Rcount
                'Filter the FilterRange on the FieldNum column
                FilterRange.AutoFilter Field:=FieldNum, _
                                       Criteria1:=Cws.Cells(Rnum, 1).Value
                'Look for the mail address in the MailInfo worksheet
                mailAddress = ""
                On Error Resume Next
                mailAddress = Application.WorksheetFunction. _
                              VLookup(Cws.Cells(Rnum, 1).Value, _
                                    Worksheets("Mailinfo").Range("A1:B" & _
                                    Worksheets("Mailinfo").Rows.Count), 2, False)
                On Error GoTo 0
                If mailAddress <> "" Then
                    With Ash.AutoFilter.Range
                        On Error Resume Next
                        Set rng = .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                    End With
                    Set OutMail = OutApp.CreateItem(0)
                    On Error Resume Next
                    With OutMail
                        .to = mailAddress
                        .Subject = Worksheets("Main sheet").Range("E2")
                        .Body = "Dear " & Sheets("Main Sheet").Range("A2").Value & vbCrLf & "We write to you regarding a cheque we issued to you on " & Sheets("Main Sheet").Range("C2").Value & " for " & Sheets("Main Sheet").Range("D2").Value
                        .Display  'Or use Send
                    End With
                    On Error GoTo 0
                    Set OutMail = Nothing
                End If
                'Close AutoFilter
                Ash.AutoFilterMode = False
            Next Rnum
        End If
        Set OutApp = Nothing
        Application.DisplayAlerts = False
        Application.DisplayAlerts = True
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End Sub

  2. #2
    Without access to your workbook it is difficult to understand its makeup from your code. However you should start Outlook using the code from the web site you referred to i.e. rather than simply creating an Outlook application. You can then use the Outlook Inspector to edit the message body directly and retain your default signature. I will assume that your counts are correct in which case the following help point you in the right direction.

    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .to = mailAddress
                        .Subject = Worksheets("Main sheet").Range("E" & Rnum)
                        .BodyFormat = 2    'html
                        .Display 'Do not delete!
                        Set olInsp = .GetInspector
                        Set wdDoc = olInsp.WordEditor    'access the message body for editing
                        Set oRng = wdDoc.Range
                        oRng.Collapse 1
                        oRng.Text = "Dear " & Sheets("Main Sheet").Range("A" & Rnum).value & vbCrLf & _
                                    "We write to you regarding a cheque we issued to you on " & Sheets("Main Sheet").Range("C" & Rnum).value & _
                                    " for " & Sheets("Main Sheet").Range("D" & Rnum).value
                        '.Send '(after testing)
                    End With
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts