email spreadsheet macro

[biglb79]

hello, does anyone know how to write a macro that would email out a spreadsheet for all the emails listed in column N on that specific tab? also, does it matter if some emails are listed twice as some people handle more than one entity?

 

[MrTomasz]

it should send entire spreadsheet to everyone listed in column N in one email or in a seperate emails?

 

[biglb79]

it should send entire spreadsheet to everyone listed in column N in one email or in a seperate emails?

it can just be one email

 

[MrTomasz]

this should send spreadsheet as attachment:

Sub test()
    Dim lastRow As Long
    Dim recipients As String
    Dim WB As Workbook
    Dim oApp As Object, oMail As Object
   
    Application.ScreenUpdating = False
       
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, "n").End(xlUp).Row
        For i = 2 To lastRow
            recipients = ";" & .Range("n" & i).Value
        Next i
    End With
    
    Set WB = ActiveWorkbook
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
        .to = recipients
        .Subject = "test subject"
        .HTMLBody = "test body" & .HTMLBody
        .Attachments.Add WB.FullName
        .Display
    End With
   
    Set oMail = Nothing
    Set oApp = Nothing

    Application.ScreenUpdating = True
End Sub

 

[biglb79]

so, is there a way to adjust this and only send the current tab instead of including all the tabs in the worksheet? also it only had one email address in the email instead of the 16 that are listed

 

[Michael M]

Try this

Sub MM1()
 Dim lastRow As Long, recipients As String, WB As Workbook
 Dim oApp As Object, oMail As Object, i As Long, filename As String
 ActiveSheet.Copy
 Set WB = ActiveWorkbook
 filename = WB.Worksheets(1).Name
 On Error Resume Next
 Kill "C:\temp\" & filename
 On Error GoTo 0
 WB.SaveAs filename:="C:\temp\" & filename
    Application.ScreenUpdating = False
 With ActiveSheet
     lastRow = .Cells(.Rows.Count, "n").End(xlUp).Row
     For i = 2 To lastRow
         recipients = recipients & ";" & .Range("n" & i).Value
     Next i
 End With
 
 Set WB = ActiveWorkbook
 Set oApp = CreateObject("Outlook.Application")
 Set oMail = oApp.CreateItem(0)
 With oMail
     .To = recipients
     .Subject = "test subject"
     .HTMLBody = "test body" & .HTMLBody
     .Attachments.Add WB.FullName
     .Display
 End With

 Set oMail = Nothing
 Set oApp = Nothing

 Application.ScreenUpdating = True
End Sub

 

[biglb79]

Try this

Sub MM1()
Dim lastRow As Long, recipients As String, WB As Workbook
Dim oApp As Object, oMail As Object, i As Long, filename As String
ActiveSheet.Copy
Set WB = ActiveWorkbook
filename = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\temp\" & filename
On Error GoTo 0
WB.SaveAs filename:="C:\temp\" & filename
    Application.ScreenUpdating = False
With ActiveSheet
     lastRow = .Cells(.Rows.Count, "n").End(xlUp).Row
     For i = 2 To lastRow
         recipients = recipients & ";" & .Range("n" & i).Value
     Next i
End With

Set WB = ActiveWorkbook
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
     .To = recipients
     .Subject = "test subject"
     .HTMLBody = "test body" & .HTMLBody
     .Attachments.Add WB.FullName
     .Display
End With

Set oMail = Nothing
Set oApp = Nothing

Application.ScreenUpdating = True
End Sub

that works! thanks so much!!!

 

[Michael M]

Pleasure...glad to help..