Want to send a range in a sheet with Outlook. But I want to give the user an option for attachment or copy

P

promo1313

New Member
Joined
Sep 4, 2019
Messages
13
Hi

I have a tool in which the user clicks a macro button and it send out the range of the sheet in the body of an email in Outlook.

We are having an issue that sometimes the range can be over 1000 rows long. The receiver will have to copy paste it in a workbook anyways, so I wanted to give the sender the option to select if they want the range sent as an attachment or in the body of the Outlook email

below is the code that I have:

VBA Code: 
Sub Main()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastRow As Long

    Set rng = Nothing
    On Error Resume Next

    lastRow = Sheets("Sheet1").Columns(1).Find("*", , xlValues, , xlByRows, xlPrevious).Row
    Set rng = Sheets("Sheet1").Range("A1:F" & lastRow).SpecialCells(xlCellTypeVisible)

    
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Sheets("Contacts").Range("F4").Value
        .CC = "isaac.santos@expeditors.com,sju-ivm@expeditors.com"
        .BCC = ""
        .Subject = "Expeditors Statement"
        .HTMLBody = RangetoHTML(rng)
        .Display 
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
Try this macro:
VBA Code: 
Sub Main()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastRow As Long
    Dim wb As Workbook, wbAttachmentFullName As String

    Set rng = Nothing
    On Error Resume Next
    lastRow = Sheets("Sheet1").Columns(1).Find("*", , xlValues, , xlByRows, xlPrevious).Row
    Set rng = Sheets("Sheet1").Range("A1:F" & lastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    wbAttachmentFullName = ""
    If lastRow > 1000 Then
        If MsgBox("There are " & lastRow & " rows.  Do you want to send the data in a .xlsx file attachment instead of in the email body?", vbYesNo) = vbYes Then
            wbAttachmentFullName = Environ("temp") & "\Data.xlsx"
            Set wb = Workbooks.Add(xlWBATWorksheet)
            rng.Copy wb.Worksheets(1).Range("A1")
            wb.SaveAs Filename:=wbAttachmentFullName, FileFormat:=xlOpenXMLWorkbook
            wb.Close False
        End If
    End If
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Sheets("Contacts").Range("F4").Value
        .CC = "isaac.santos@expeditors.com,sju-ivm@expeditors.com"
        .BCC = ""
        .Subject = "Expeditors Statement"
        If wbAttachmentFullName <> "" Then
            .Attachments.Add wbAttachmentFullName
            Kill wbAttachmentFullName
        Else
            .HTMLBody = RangetoHTML(rng)
        End If
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Upvote 0
John_w said:
Try this macro:
VBA Code: 
Sub Main()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastRow As Long
    Dim wb As Workbook, wbAttachmentFullName As String

    Set rng = Nothing
    On Error Resume Next
    lastRow = Sheets("Sheet1").Columns(1).Find("*", , xlValues, , xlByRows, xlPrevious).Row
    Set rng = Sheets("Sheet1").Range("A1:F" & lastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    wbAttachmentFullName = ""
    If lastRow > 1000 Then
        If MsgBox("There are " & lastRow & " rows.  Do you want to send the data in a .xlsx file attachment instead of in the email body?", vbYesNo) = vbYes Then
            wbAttachmentFullName = Environ("temp") & "\Data.xlsx"
            Set wb = Workbooks.Add(xlWBATWorksheet)
            rng.Copy wb.Worksheets(1).Range("A1")
            wb.SaveAs Filename:=wbAttachmentFullName, FileFormat:=xlOpenXMLWorkbook
            wb.Close False
        End If
    End If
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Sheets("Contacts").Range("F4").Value
        .CC = "isaac.santos@expeditors.com,sju-ivm@expeditors.com"
        .BCC = ""
        .Subject = "Expeditors Statement"
        If wbAttachmentFullName <> "" Then
            .Attachments.Add wbAttachmentFullName
            Kill wbAttachmentFullName
        Else
            .HTMLBody = RangetoHTML(rng)
        End If
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Click to expand...
AwesomE!

Thanks John!
 
Upvote 0
John_w said:
Try this macro:
VBA Code: 
Sub Main()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastRow As Long
    Dim wb As Workbook, wbAttachmentFullName As String

    Set rng = Nothing
    On Error Resume Next
    lastRow = Sheets("Sheet1").Columns(1).Find("*", , xlValues, , xlByRows, xlPrevious).Row
    Set rng = Sheets("Sheet1").Range("A1:F" & lastRow).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    wbAttachmentFullName = ""
    If lastRow > 1000 Then
        If MsgBox("There are " & lastRow & " rows.  Do you want to send the data in a .xlsx file attachment instead of in the email body?", vbYesNo) = vbYes Then
            wbAttachmentFullName = Environ("temp") & "\Data.xlsx"
            Set wb = Workbooks.Add(xlWBATWorksheet)
            rng.Copy wb.Worksheets(1).Range("A1")
            wb.SaveAs Filename:=wbAttachmentFullName, FileFormat:=xlOpenXMLWorkbook
            wb.Close False
        End If
    End If
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Sheets("Contacts").Range("F4").Value
        .CC = "isaac.santos@expeditors.com,sju-ivm@expeditors.com"
        .BCC = ""
        .Subject = "Expeditors Statement"
        If wbAttachmentFullName <> "" Then
            .Attachments.Add wbAttachmentFullName
            Kill wbAttachmentFullName
        Else
            .HTMLBody = RangetoHTML(rng)
        End If
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Click to expand...
Hi John,

Actually, i just noticed that the attachment doesent copy the data. It shows 0's with the formulas from the cells. The email body text appears fine though is selecting that option.
 
Upvote 0
So you just want values? Change the rng.Copy to:
VBA Code: 
            rng.Copy
            wb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
Upvote 0
John_w said:
So you just want values? Change the rng.Copy to:
VBA Code: 
            rng.Copy
            wb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Click to expand...
Hi John,

Sorry for the late reply. Got caught up in another project.
Thank you for the last code. I see that it does paste the values in a new workbook, but it does not continue the code to close it and open outlook then attaches it.
I pastes the data in a new workbook, then stays open.
 
Upvote 0
The wb.Close False should close the temporary workbook attachment. Comment out the On Error Resume Next above the With OutMail and see if any errors occur when you run the macro
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Combining two codes by Using a Messagebox like Form with yes/no or alike
Replies
1
Views
120
lojanica
L
S
  • Question
VBA Code hangs on Outlook Send?
Replies
2
Views
367
shophoney
S
T
  • Question
VBA- Copy & Paste Range into Outlook as a Picture
Replies
1
Views
129
Domenic
D
M
  • Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
184
mecerrato
M
G
  • Question
Email from Excel query
Replies
0
Views
170
gmazza76
G

Forum statistics

Threads
1,215,064
Messages
6,122,936
Members
449,094
Latest member
teemeren

Share this page

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
Back
Top