Sending 2 Worksheets via email

[WxShady13]

I have a workbook that has several worksheets tracking data. I currently have the code to send 1 worksheet and a button located on that sheet. How do I tweak the code to send both sheets in one email?

 'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

 

[SpillerBD]

I have a macro that I would use to send selected sheets individually.
I have modified that to be very close to what you are looking for.
It creates a draft message and opens it so you can review and modify the email before actually sending.

Sub Send_as1_Draft_Worksheets()
    ' Public item Dim ws As Worksheet
    Dim OutlookApp As Outlook.Application
    Dim DisplayStatusBar As Boolean
    Dim DestinationPath As Variant
    Dim ws As Variant
    
    DisplayStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = ActiveWindow.SelectedSheets.Count & " Remaining Sheets"
    
    'For Each ws In ActiveWindow.SelectedSheets
    With ActiveWindow.SelectedSheets
        Dim NewFileName As String
    'ws.Select
    NewFileName = "C:\temp\" & "Tracking Data" & ".xlsx"
    .Copy
    ' The macro over writes any previous file.
    ActiveWorkbook.SaveAs fileName:=NewFileName, _
        FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
'Set Email Info
    Set OutlookApp = New Outlook.Application
'      Msg = "Dear " & Recipient & vbCrLf & vbCrLf _
'        & "Here's a copy of the .... " _
'        & "--- " _
'        & ",,,," & vbCrLf & vbCrLf _
'        & "Thanks for your help."
'
    Msg = "Predefined message Text"
'Create Mail Item and send it
      Set MItem = OutlookApp.CreateItem(olMailItem)
      With MItem
        '.To = ws.Range("A1").Value  ' Each worksheet to be sent should have
                                    ' SendTo Email information in Cell A1
                                    ' Multiple Email addresses seperated
                                    ' By semi-colons.
        .Subject = "Shrink Or Gross Profit Inventory Reporting"
        .Body = Msg
        .Attachments.Add (NewFileName)
        '.Send 'Send immediately
        .Display 'Save to Drafts folder
      End With
      Kill NewFileName  ' Deletes Each filename after use.
                        ' To keep files comment out the Kill statement.
End With
'Next
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.DisplayStatusBar = DisplayStatusBar
    Application.ScreenUpdating = True
    Close 'close all files and folders?
End Sub

 

[WxShady13]

Thank you!!!! This is awesome