Excel VBA macro send a selection of current workbook as attachment to an email

Question

I need to send only a selection of the active workbook as an attachment in an email to some recipients. How do I modify below's code in order to send only a selected range of the current workbook?

Below's code works completely fine but sends the complete active workbook. How do I send the range of A1:M35?

Appreciate your help!

Sub Mail_to_recipients()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim myDataRng As Range
    Dim cell As Range
    Dim iCnt As Integer
    Dim sMail_ids As String
    Dim TempFilePath As String
    Dim FileExt As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim FileFormat As Variant
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Wb1 = ThisWorkbook
    ActiveSheet.Copy
    Set Wb2 = ActiveWorkbook

    'Below code will get the File Extension and
    'the file format which we want to save the copy
    'of the workbook with the active sheet.

    With Wb2
        If Val(Application.Version) < 12 Then
             FileExt = ".xls": FileFormat = -4143
        Else
            Select Case Wb1.FileFormat
            Case 51: FileExt = ".xlsx": FileFormat = 51
            Case 52:
                If .HasVBProject Then
                    FileExt = ".xlsm": FileFormat = 52
                Else
                    FileExt = ".xlsx": FileFormat = 51
                End If
            Case 56: FileExt = ".xls": FileFormat = 56
            Case Else: FileExt = ".xlsb": FileFormat = 50
            End Select
        End If
    End With

    'Save your workbook in your temp folder of your system
    'below code gets the full path of the temporary folder
    'in your system

    TempFilePath = Environ$("temp") & "\"

    'Now append a date and time stamp
    'in your new file

    TempFileName = Wb1.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")

    'Complete path of the file where it is saved
    FileFullPath = TempFilePath & TempFileName & FileExt

    'Now save your currect workbook at the above path
    Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

 
    Set myDataRng = Range("AJ5:AJ10" & Cells(Rows.Count, "AJ").End(xlUp).Row)
    ' Run a loop to extract email ids from the 2nd column.
    For Each cell In myDataRng
        If Trim(sMail_ids) = "" Then
            sMail_ids = cell.Offset(1, 0).Value
        Else
            sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
        End If
    Next cell
    
    Set myDataRng = Nothing         ' Clear the range.

    On Error Resume Next
    With OutMail
        .To = sMail_ids
        .CC = ""
        .BCC = ""
        .Subject = "Weekindeling week " & Range("K1")
        .Attachments.Add FileFullPath
        .Display
    End With
    On Error GoTo 0
    
    'Since mail has been sent with the attachment
    'Now close and delete the temp file from the
    'temp folder
    Wb2.Close SaveChanges:=False
    Kill FileFullPath

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Answer 1

The following code will create a new workbook with one sheet, copy the range A1:M35 of the active sheet of the workbook the code is in to the new workbook and email the new workbook as an attachment.

Sub Mail_to_recipients()

Dim OutApp As Object
Dim OutMail As Object
Dim myDataRng As Range
Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim Wb1 As Workbook
Dim Wb2 As Workbook

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Wb1 = ThisWorkbook

    Set Wb2 = Workbooks.Add(xlWBATWorksheet)
    
    Wb1.ActiveSheet.Range("A1:M35").Copy Wb2.Sheets(1).Range("A1")
    
    Wb2.Sheets(1).Name = Wb1.ActiveSheet.Name

    'Below code will get the File Extension and
    'the file format which we want to save the copy
    'of the workbook with the active sheet.

    With Wb2
        If Val(Application.Version) < 12 Then
            FileExt = ".xls": FileFormat = -4143
        Else
            Select Case Wb1.FileFormat
                Case 51: FileExt = ".xlsx": FileFormat = 51
                Case 52:
                    If .HasVBProject Then
                        FileExt = ".xlsm": FileFormat = 52
                    Else
                        FileExt = ".xlsx": FileFormat = 51
                    End If
                Case 56: FileExt = ".xls": FileFormat = 56
                Case Else: FileExt = ".xlsb": FileFormat = 50
            End Select
        End If
    End With

    'Save your workbook in your temp folder of your system
    'below code gets the full path of the temporary folder
    'in your system

    TempFilePath = Environ$("temp") & "\"

    'Now append a date and time stamp
    'in your new file

    TempFileName = Wb1.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")

    'Complete path of the file where it is saved
    FileFullPath = TempFilePath & TempFileName & FileExt

    'Now save your currect workbook at the above path
    Wb2.SaveAs FileFullPath, FileFormat:=FileFormat

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


    Set myDataRng = Wb1.ActiveSheet.Range("AJ5:AJ10" & Cells(Rows.Count, "AJ").End(xlUp).Row)
    ' Run a loop to extract email ids from the 2nd column.
    For Each cell In myDataRng
        If Trim(sMail_ids) = "" Then
            sMail_ids = cell.Offset(1, 0).Value
        Else
            sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
        End If
    Next cell

    Set myDataRng = Nothing         ' Clear the range.

    On Error Resume Next
    With OutMail
        .To = sMail_ids
        .CC = ""
        .BCC = ""
        .Subject = "Weekindeling week " & Range("K1")
        .Attachments.Add FileFullPath
        .Display
    End With
    On Error GoTo 0

    'Since mail has been sent with the attachment
    'Now close and delete the temp file from the
    'temp folder
    Wb2.Close SaveChanges:=False
    Kill FileFullPath

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

    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub