email worksheet

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
640
Office Version
  1. 365
Platform
  1. Windows
good evening,

I have a workbook with several worksheets, but I only need to email one of the worksheets. The recipient will always be the same.

Could some kind coder help me & would be able to sort this for me?

I have tried via 'record macro' but failed.

MTIA & KR
Trevor3007:cool:
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,474
.
Code:
Option Explicit


Sub Email_Worksheet_As_Workbook()
    ActiveSheet.Copy                        '<--- edit as required"
    With ActiveWorkbook
        '.Windows(1).Visible = False
        Application.DisplayAlerts = False
        .SaveAs Environ("TMP") & "\Your Sheet Name.xlsx", FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
        Application.DisplayAlerts = True
        .Close (True)
    End With
    
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "me@yahoo.com"
        .Subject = "Worksheet: " & ActiveSheet.Name
        .Body = ""
        .Attachments.Add Environ("TMP") & "\Your Sheet Name.xlsx"
        .Display
        '.send
    End With
End Sub
 

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
640
Office Version
  1. 365
Platform
  1. Windows
.
Code:
Option Explicit


Sub Email_Worksheet_As_Workbook()
    ActiveSheet.Copy                        '<--- edit as required"
    With ActiveWorkbook
        '.Windows(1).Visible = False
        Application.DisplayAlerts = False
        .SaveAs Environ("TMP") & "\Your Sheet Name.xlsx", FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
        Application.DisplayAlerts = True
        .Close (True)
    End With
    
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "me@yahoo.com"
        .Subject = "Worksheet: " & ActiveSheet.Name
        .Body = ""
        .Attachments.Add Environ("TMP") & "\Your Sheet Name.xlsx"
        .Display
        '.send
    End With
End Sub


Thanks very much logit for again your assistance.

I used your code & edited as you instructed..but failed :(


Code:
Option Explicit
 
 
Sub Email_Worksheet_As_Workbook()
    ActiveSheet.Copy                        “[COLOR=#ff0000]sheet3[/COLOR]"
    With ActiveWorkbook
        '.Windows(1).Visible = False
        Application.DisplayAlerts = False
        .SaveAs Environ("TMP") & "[COLOR=#ff0000] C:\Users\data\Desktop\pilot_v007.xlsm[/COLOR] ", FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
        Application.DisplayAlerts = True
        .Close (True)
    End With
   
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "me@yahoo.com"
        .Subject = "Worksheet: " & ActiveSheet.Name
        .Body = ""
        .Attachments.Add Environ("TMP") & "\[COLOR=#ff0000]sheet3[/COLOR].xlsm"
        .Display
        '.send
    End With
End Sub

My (b)adds are highlighted in red


Error message 'runtime error 1004..

hope you can sort & thank you for your help.

KR
Trevor3007
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,474
.
Try this :

Code:
Option Explicit
 
 
Sub Email_Worksheet_As_Workbook()
    Sheets("Sheet3").Copy                        '“sheet3"
    With ActiveWorkbook
        '.Windows(1).Visible = False
        Application.DisplayAlerts = False
        .SaveAs Environ("TMP") & "pilot_v007.xlsx", FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
        Application.DisplayAlerts = True
        .Close (True)
    End With
   
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "me@yahoo.com"
        .Subject = "Worksheet: " & ActiveSheet.Name
        .Body = ""
        .Attachments.Add Environ("TMP") & "\pilot_v007.xlsx"
        .Display
        '.send
    End With
End Sub
 

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
640
Office Version
  1. 365
Platform
  1. Windows
.
Try this :

Code:
Option Explicit
 
 
Sub Email_Worksheet_As_Workbook()
    Sheets("Sheet3").Copy                        '“sheet3"
    With ActiveWorkbook
        '.Windows(1).Visible = False
        Application.DisplayAlerts = False
        .SaveAs Environ("TMP") & "pilot_v007.xlsx", FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
        Application.DisplayAlerts = True
        .Close (True)
    End With
   
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "me@yahoo.com"
        .Subject = "Worksheet: " & ActiveSheet.Name
        .Body = ""
        .Attachments.Add Environ("TMP") & "\pilot_v007.xlsx"
        .Display
        '.send
    End With
End Sub



Hi logit,

thanks for getting back to me & for your help too.

Still getting errors :(

Using the following (please note the file name differs from previous)

Code:
  Sub Email_Worksheet_As_Workbook()[COLOR=#ff0000]    Sheets("Sheet3").Copy                        '"sheet3"[/COLOR]
    With ActiveWorkbook
        '.Windows(1).Visible = False
        Application.DisplayAlerts = False
        .SaveAs Environ("TMP") & " C:\Users\work3\Desktop\BuildLT_v007.xlsm", FileFormat:=xlWorkbookDefault, ConflictResolution:=xlLocalSessionChanges
        Application.DisplayAlerts = True
        .Close (True)
    End With
   
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "me@yahoo.com"
        .Subject = "Worksheet: " & ActiveSheet.Name
        .Body = ""
        .Attachments.Add Environ("TMP") & "\BuildLT_v007.xlsm "
        .Display
        '.send
    End With
 


End Sub


runtime error 9
subscript out of range & highlights Sheets("Sheet3").Copy '"sheet3" in YELLOW

also, the sheet name will change on every email sent..will this inpact?

MTIA & KR
Trevor3007
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,474
.
Here is a different project. You can use it in the manner you first described ... sending an email to the same person each time with a worksheet attached.
You can also use it to send to multiple email addresses, with or without attachments.
It gives you the option to change the SUBJECT & BODY as well.

Place the workbook on your desktop.

It will save all of the worksheets in the workbook to a newly created folder on your desktop. It then attaches the sheets you have designated in the
column F, G, H to the email in the same row.

When the process is complete, the program deletes the newly created folder holding the sheet copies - everything gets cleaned up ready for the next use.

Download link : https://www.amazon.com/clouddrive/share/VlhZfQNGcklXuKO6Zq2KDa8oMPQcywwBVffz2LIgwp5




Code:
Option Explicit


Sub CreateMail()
    Dim objOutlook      As Object
    Dim objMail         As Object
    Dim i               As Integer
    Const olMailItem    As Long = 0
                                    
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row '~~> Change to i = 2 if you have headings
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(olMailItem)
                                        
        With objMail '~~> Chnage Below columns to suit your data, this was based off your example offsets
            .To = Range("A" & i).Value
            .CC = Range("B" & i).Value
            .BCC = Range("C" & i).Value
            .Subject = Range("D" & i).Value
            
            If Range("F" & i).Value <> "" Then
                .Attachments.Add Range("F" & i).Value
            End If
            If Range("G" & i).Value <> "" Then
                .Attachments.Add Range("G" & i).Value
            End If
            If Range("H" & i).Value <> "" Then
                .Attachments.Add Range("H" & i).Value
            End If
            
            .HTMLBody = RangetoHTML(Range("E" & i)) '~~> You can change this to any range
            .Display
            '.Send       'uncomment this line to automatically send emails without reviewing first
                         ' NOT A GOOD IDEA ! There could be errors. Proof read before sending.
        End With
                                        
        Set objOutlook = Nothing
        Set objMail = Nothing
    Next i
    DeleteFiles
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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 new workbook to past the data in
    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 a 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 RangetoHTML
    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 we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


Sub SaveShtsAsBook()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         '      End With
        On Error Resume Next '<< a folder exists
        MkDir MyFilePath '<< create a folder
        For N = 1 To Sheets.Count
            Sheets(N).Activate
            SheetName = ActiveSheet.Name
            Cells.Copy
            Workbooks.Add (xlWBATWorksheet)
            With ActiveWorkbook
                With .ActiveSheet
                    .Paste
                    .Name = SheetName
                    [A1].Select
                End With
                 'save book in this folder
                .SaveAs Filename:=MyFilePath _
                & "\" & SheetName & ".xlsx"              '
                .Close SaveChanges:=True
            End With
            .CutCopyMode = False
        Next
    End With
    Sheet1.Activate
    CreateMail
End Sub


Sub DeleteFiles()
Dim aFile As String, bFile As String


aFile = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "\" & "*.*"
bFile = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "\"


If Len(Dir$(aFile)) > 0 Then
    Kill aFile
End If


Application.Wait (Now + TimeValue("0:00:01"))
Application.WindowState = xlMinimized
Application.Visible = False
RmDir bFile


Application.Quit
End Sub


Sub clrColF()
    Range("F2:H100").Clear
End Sub
 
Last edited:

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
640
Office Version
  1. 365
Platform
  1. Windows
.
Here is a different project. You can use it in the manner you first described ... sending an email to the same person each time with a worksheet attached.
You can also use it to send to multiple email addresses, with or without attachments.
It gives you the option to change the SUBJECT & BODY as well.

Place the workbook on your desktop.

It will save all of the worksheets in the workbook to a newly created folder on your desktop. It then attaches the sheets you have designated in the
column F, G, H to the email in the same row.

When the process is complete, the program deletes the newly created folder holding the sheet copies - everything gets cleaned up ready for the next use.

Download link : https://www.amazon.com/clouddrive/share/VlhZfQNGcklXuKO6Zq2KDa8oMPQcywwBVffz2LIgwp5




Code:
Option Explicit


Sub CreateMail()
    Dim objOutlook      As Object
    Dim objMail         As Object
    Dim i               As Integer
    Const olMailItem    As Long = 0
                                    
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row '~~> Change to i = 2 if you have headings
        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(olMailItem)
                                        
        With objMail '~~> Chnage Below columns to suit your data, this was based off your example offsets
            .To = Range("A" & i).Value
            .CC = Range("B" & i).Value
            .BCC = Range("C" & i).Value
            .Subject = Range("D" & i).Value
            
            If Range("F" & i).Value <> "" Then
                .Attachments.Add Range("F" & i).Value
            End If
            If Range("G" & i).Value <> "" Then
                .Attachments.Add Range("G" & i).Value
            End If
            If Range("H" & i).Value <> "" Then
                .Attachments.Add Range("H" & i).Value
            End If
            
            .HTMLBody = RangetoHTML(Range("E" & i)) '~~> You can change this to any range
            .Display
            '.Send       'uncomment this line to automatically send emails without reviewing first
                         ' NOT A GOOD IDEA ! There could be errors. Proof read before sending.
        End With
                                        
        Set objOutlook = Nothing
        Set objMail = Nothing
    Next i
    DeleteFiles
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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 new workbook to past the data in
    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 a 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 RangetoHTML
    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 we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


Sub SaveShtsAsBook()
    Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
    MyFilePath$ = ActiveWorkbook.Path & "\" & _
    Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
         '      End With
        On Error Resume Next '<< a folder exists
        MkDir MyFilePath '<< create a folder
        For N = 1 To Sheets.Count
            Sheets(N).Activate
            SheetName = ActiveSheet.Name
            Cells.Copy
            Workbooks.Add (xlWBATWorksheet)
            With ActiveWorkbook
                With .ActiveSheet
                    .Paste
                    .Name = SheetName
                    [A1].Select
                End With
                 'save book in this folder
                .SaveAs Filename:=MyFilePath _
                & "\" & SheetName & ".xlsx"              '
                .Close SaveChanges:=True
            End With
            .CutCopyMode = False
        Next
    End With
    Sheet1.Activate
    CreateMail
End Sub


Sub DeleteFiles()
Dim aFile As String, bFile As String


aFile = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "\" & "*.*"
bFile = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "\"


If Len(Dir$(aFile)) > 0 Then
    Kill aFile
End If


Application.Wait (Now + TimeValue("0:00:01"))
Application.WindowState = xlMinimized
Application.Visible = False
RmDir bFile


Application.Quit
End Sub


Sub clrColF()
    Range("F2:H100").Clear
End Sub


good evening logit,

Thank you for your help. It is very much appreciated.



Unintentionally, I may have mislead you?


(1) My current issue:-

workbook with several worksheets. Need macro button to be able to email sheet3 to the same recipient rather than have to have to the normal methodology . The tab name on the applicable worksheet will change each time it is emailed.


(2) Previous issue

To attach multiple files and email using a predefined template .

The VBA you sent works great..its the issue with the 'multi attachments' that is my issue



So the VBA (re https://www.amazon.com/clouddrive/share/VlhZfQNGcklXuKO6Zq2KDa8oMPQcywwBVffz2LIgwp5) you have spent time to sort, appears to be for my 2 issue?


I truly appreciate your help & wish I had the knowledge, but apart from 'record a macro' & bit of tweaking ..I am totally lost.

Hoping this explanation has helped & not hindered.



NP if what I ask is not viable or time consuming.

all the very best.
KR
Trevor3007:cool:
 
Last edited:

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,474
.
Using the last example workbook listed as a download ... change Sheet2 tab name to My Sheet.

Then in the Attachments Col F:H ... where ever you see C:\Users\My\Desktop\Works MultiMail w Attachment\Sheet2.xlsx .. change that to

C:\Users\My\Desktop\Works MultiMail w Attachment\ My Sheet.xlsx ... then run the code.


NOTE: change the word My ​to correspond to the name of your computer.
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,474
.
Just noticed an error in my last post:

This line : C:\Users\My\Desktop\Works MultiMail w Attachment\ My Sheet.xlsx

should not have a space after the last " \ " symbol.

My apologies for the typographical error.
 

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
640
Office Version
  1. 365
Platform
  1. Windows
.
Just noticed an error in my last post:

This line : C:\Users\My\Desktop\Works MultiMail w Attachment\ My Sheet.xlsx

should not have a space after the last " \ " symbol.

My apologies for the typographical error.

good morning morning logit

many thanks again for your assistance. I have not had time yet to test.....i just thought id reply and thank you.

KR
Trevor3007
 
Last edited:

Forum statistics

Threads
1,170,959
Messages
5,872,995
Members
432,955
Latest member
minhnhat2504

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top