Send specific worksheet as attachment via mail (Condition)

[yncmkl]

Hello together,

This is my first post. Happy to be part of this.

I have created an excel projectplan including nearly 40 milestone-tabs. My goal is to remind the respective milestone owners via email if tasks are due. Actually, this works pretty good using the code examples of Ron.

There is one thing that I also want to include:
The email should include a specific excel worksheet as an attachment. I am using the following code that attaches the active worksheet (https://www.rondebruin.nl/win/s1/outlook/amail2.htm)

Unfortunately, I am not able to manage to rewrite the code.

What I want to achieve:
My current version of the project plan includes a reminder worksheet, where all the data is stored necessary to generate my reminder. One column includes the name of the milestones. All of the milestones are available as separate worksheets. If the email is generated I want to achieve that a worksheet is added that is mentioned in the column in the Reminder Tab. For example: If there is the entry "Milestone1" in the column of the reminder worksheet then I want to add the Milestone1 Worksheet to the email as attachment

Hope there is anyone who might help me solve this.

Thank you very much for your help.

Best
Yannick

 

[ranman256]

can you:

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
          'and get the Milestone sheet
      Sourcewb.Sheets("milestones").copy Before:=Destwb.Sheets(1)

 

[yncmkl]

Thank you! Actually I am a total newbie in VBA. Attached you can see my current code. Where do I have to add your proposed code?

Thank You!

Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim CC As String
Dim eSubject As String
Dim eBody As String
Dim status As String
Dim reminder As String
Dim milestoneowner As String
Dim milestoneownercontact As String
Dim milestonecode As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
Set Sourcewb = ActiveWorkbook
    'Copy the sheets to a new workbook
    'We add a temporary Window to avoid the Copy problem
    'if there is a List or Table in one of the sheets and
    'if the sheets are grouped
    With Sourcewb
        Set TheActiveWindow = ActiveWindow
        Set TempWindow = .NewWindow
        .Sheets(Array("Sheet1")).Copy
    End With
    'Close temporary Window
    TempWindow.Close
    Set Destwb = ActiveWorkbook
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
    '    'Change all cells in the worksheets to values if you want
    For Each sh In Destwb.Worksheets
    sh.Select
    With sh.UsedRange
    .Cells.Copy
    .Cells.PasteSpecial xlPasteValues
    .Cells(1).Select
    End With
    Application.CutCopyMode = False
    Destwb.Worksheets(1).Select
    Next sh
    
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name

Sheets(1).Select
lRow = Cells(Rows.Count, 12).End(xlUp).Row
For i = 2 To lRow
toDate = Replace(Cells(i, 12), ".", "/")
status = Cells(i, 10)
reminder = Cells(i, 14)
milestoneowner = Cells(i, 4)
milestoneownercontact = Cells(i, 5)
  If Left(Cells(i, 13), 4) <> "Mail" And toDate - Date <= 7 And status <> 1 And reminder = "x" Then
     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)
     
         With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
    
        toList = Cells(i, 3)
        CC = Cells(i, 6)
        eSubject = "REMINDER: Task DUE"
        eBody = ""
                
        On Error Resume Next
        SendKeys "^{ENTER}"
        With OutMail
        .to = toList
        .CC = CC
        .BCC = ""
        .Subject = eSubject
        .HTMLBody = eBody
        .bodyformat = olFormatHTML
        .Attachments.Add Destwb.FullName
        .Display
        SendKeys "^{ENTER}"
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
    
    Kill TempFilePath & TempFileName & FileExtStr
    
    Set OutMail = Nothing
    Set OutApp = Nothing
 Cells(i, 13) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i
ActiveWorkbook.Save
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub