Email with rows included in VBA

[pikepro92]

Hi folks,

Bit of a VBA novice. Would be grateful if anyone can help with the code. I have data like the below and I want to send one email to each unique email address in column E, copying in the address in column B.

In the body of the email, I want to have all the rows for that country like below:

 

[pikepro92]

Can't do that with the macro that creates an the HTML table from the cell content. So the following doesn't need the RangetoHTML function.

I have to use the autofilter macro above your post but modified to place the rows in a new workbook for attaching.
Try this to see if it works.
It should attach a file based on the macro workbook name + the date. The attached files are hard coded to be .xlsx
I used your table in the initial post for testing it.

Sub Autofilter_1()

Dim MailBody As Range

'Turn Off autofilter if on
  ActiveSheet.AutoFilterMode = False

Set mWs = ThisWorkbook.Worksheets("Sheet1")

'Get this workbook name to name the attachment as this workbook and date
Nme = (Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5))

'Set email address as range for first loop to run down
    Set rng = Range(Range("E2"), Range("E" & Rows.Count).End(xlUp))


For Each cell In rng
If cell.Value <> "" Then
If Not cell.Offset(0, 2).Value = "yes" Then

'Add New Workbook
    Set MailWb = Workbooks.Add
   
'Activate the main page and filter
    mWs.Activate
    Worksheets("Sheet1").Range("A1").AutoFilter Field:=5, Criteria1:=cell.Value

'Copy the filter rows to the new workbook including the header
    With ActiveSheet.AutoFilter.Range.Offset(0, 0)
    .Copy MailWb.Worksheets("Sheet1").Range("A1")
    End With

'Use visible cells property so only autofiltered cell rows are changed
    For Each dwn In rng.SpecialCells(xlCellTypeVisible)
    rng.Offset(0, 2).Value = "yes"
    Next

'Turn off autofilter
    ActiveSheet.AutoFilterMode = False

'Mail header parameters
    MailTo = cell.Value 'column E
    mailcc = cell.Offset(0, -3).Value
    MailSubject = "Subject?"
   

'Autofit the copied rows on the new sheet
    With MailWb.Worksheets("Sheet1")

    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set mailRng = .Range(.Cells(1, 1), .Cells(lRow, 6))
    .Range("A1:F2").Columns.AutoFit

  End With


'Add mail intro
    MsgStr = "Hi" & cell.Offset(0, 1).Value _
    & "<br><br> Please see attached "


'Save the new workbook as an xlsx file
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Nme & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx"
   
   
'Add mail intro
    MsgStr = "Hi" & cell.Offset(0, 1).Value _
    & vbNewLine & vbNewLine & "Please see attached: " _
    & vbNewLine & TempFileName
   
'Create mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With MailWb
        .SaveAs TempFilePath & TempFileName, FileFormat:=51
        On Error Resume Next
        With OutMail
            .to = MailTo
            .CC = mailcc
            .BCC = ""
            .Subject = MailSubject
            .Body = MsgStr
            .Attachments.Add MailWb.FullName
            .Display
            '.Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

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

End If
End If


MailTo = ""
MailSubject = ""
Next

End Sub

Thanks im getting an error run time 9. Please see attached image. The table im working on is goes to column S.

 

[daverunt]

You changed all of the Sheet1 references to Sheet5. However
A new Workbook will only contain "Sheet1".

So any reference to MailWb.Worksheets should be Sheet1. (There's more than 1.)

You'll also need to change the 6 to 19 for the autofit.

Set mailRng = .Range(.Cells(1, 1), .Cells(lRow, 19))

Also the mail message needs updating as the old one was for HTMLBody in the code it was copied from

'Add mail intro
    MsgStr = "Hi" & cell.Offset(0, 1).Value _
    & vbNewLine & vbNewLine & "Please see attached: " _
    & vbNewLine & TempFileName

 

[pikepro92]

how would i select only certain fields to be copied to the new workbook?

 

[daverunt]

Hi,

one way is to hide the column(s) you don't want to send prior to running the macro.
The code is added to count the hidden columns between to code shown.

You need to set the range to whatever is the normal last column - I put in A:G (1 to 6)
When you hide a column, or several it will count them into colCount.

This hidden colCount is subtracted from the copied filtered rows/columns.

'Get this workbook name to name the attachment as this workbook and date
Nme = (Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5))

'----------inserted
'Set the column range for the current table then count any that are hidden
   For Each Col In mWs.Range("A1:G1").Columns
    If Col.EntireColumn.Hidden = True Then
        colCount = colCount + 1
    End If
Next Col
'---------------
'Set email address as range for first loop to run down
    Set rng = Range(Range("F2"), Range("F" & Rows.Count).End(xlUp))


~~~~~

'Autofit the copied rows on the new sheet
    With MailWb.Worksheets("Sheet1")


'Copy the number of columns less the hidden columns count
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set mailRng = .Range(.Cells(1, 1), .Cells(lRow, 6 - colCount))   'subtract colCount from whatever column number you have set here.
    .Range("A1:F2").Columns.AutoFit

  End With

 

[daverunt]

Forgot - unhide any hidden columns after all mails sent.

MailTo = ""
MailSubject = ""
Next

'---------------inserted - Ato G again needs correcting----------
'To UnHide Columns Ato G
mWs.Columns("A:G").EntireColumn.Hidden = False

End Sub

------------------------