VBA - Sending Attachnments via Lotus Email, How to Optimize my Code?

[MagicalHippo]

Hello guys! I have created a in-depth Macro that runs through a set of names in Column A of a Master sheet, sorts each name against a Table, copies the range into an attachment, and fires off an email to this person's name. My question is, how do I better optimize my code below? Right now it takes ~5 minutes to run and complete a list of 30 names.

Things I have thought of:
1) Putting list of Employee Names in Column A into an Array
2) Copying all ranges into an Array and pasting each Array value to a attachment with name from above array (Step 1)


Here is my code, hoping to learn a lot from the Guru's here

Public copyrange As Range
Public employeeName As String
Public TrimName As String, EmailName As String


Sub Copyvalue()
Dim rng As Range, Dn As Range
Dim Lstrow As Long, n As Long, LstCol As Long, lastrowMaster As Long, i As Long
Dim ws As Worksheet, ws2 As Worksheet, MasterEmployee As Worksheet, master As Workbook
Dim pivitem As Long
Dim PT As Excel.PivotTable

Call MasterEmployeelist
Set MasterEmployee = ThisWorkbook.Worksheets("Dataset")
Set master = ThisWorkbook
Set PT = master.Worksheets("Plan").PivotTables("PivotTable2")
lastrowMaster = MasterEmployee.Range("A" & Rows.Count).End(xlUp).Row
master.Worksheets("Plan").Activate
With master.Worksheets("Plan")
.PivotTables("PivotTable2").PivotSelect "", xlDataAndLabel, True
Selection.Copy
End With
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
ws.Name = "PlanTable"
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Monthly schedule").Select
Range("B2:B13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("PlanTable").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

Call HideDates
With ws
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$AA$493"), , xlYes).Name = _
"Table1"
Range("Table1[#All]").Select
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
End With

For j = 1 To lastrowMaster
employeeName = MasterEmployee.Cells(j, 1).Text
TrimName = Right(employeeName, Len(employeeName) - 4)

With ws
.Range("A1", .Range("A" & .Rows.Count).End(xlUp)) _
.AutoFilter Field:=1, Criteria1:=Application.Transpose(employeeName), Operator:=xlFilterValues
LstCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
Lstrow = .Range("A" & Rows.Count).End(xlUp).Row
Set copyrange = .Range("A1:AA" & Lstrow)
End With
copyrange.Select
copyrange.SpecialCells(xlCellTypeVisible).Copy

Const EMBED_ATTACHMENT As Long = 1454
Const stPath As String = "c:\Attachments"
Const stSubject As String = "Weekly report"

Dim vaMsg As String
vaMsg = "Hi " & TrimName & ", Below is your updated BSA allocation to projects from now until the end of the year." & vbCrLf & _
"Please communicate with me or your respective pm(s) if this allocation does not align to your understanding." & vbCrLf & _
"Thanks...Debbie"
Const vaCopyTo As Variant = "name@mail.com"

Dim stFileName As String
Dim vaRecipients As Variant

Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String

'Copy the active sheet to a new temporarily workbook.
With ws
.Copy
End With
stFileName = employeeName
stAttachment = stPath & "" & stFileName & ".xls"

'Save and close the temporarily workbook.
With ActiveWorkbook
.Worksheets(1).Protect Password:=Whatever
.SaveAs stAttachment
.Close
End With

'Create the list of recipients.
vaRecipients = VBA.Array("MR WHO")

'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GetDatabase("", "")

'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL

'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)

'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
.CopyTo = vaCopyTo
.Subject = stSubject
.Body = vaMsg
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, vaRecipients
End With

'Delete the temporarily workbook.
Kill stAttachment

'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing


ws.Activate
ActiveSheet.AutoFilterMode = False
Next j
MsgBox "The e-mail has successfully been created and distributed", vbInformation
thisworkbook.Close SaveChanges:=False
End Sub

A lot of this has been copied and modified from various parts of the internet, looking for ways to help decrease runtimes

 

[Norie]

You could start by getting rid of all the Activate/Select stuff.

Option Explicit

Const EMBED_ATTACHMENT As Long = 1454
Const stPath As String = "c:\Attachments"
Const stSubject As String = "Weekly report"

Public copyrange As Range
Public employeeName As String
Public TrimName As String, EmailName As String

Sub Copyvalue()
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim PT As Excel.PivotTable
Dim stFileName As String
Dim vaRecipients As Variant
Dim stAttachment As String
Dim rng As Range, Dn As Range
Dim Lstrow As Long, n As Long, LstCol As Long, lastrowMaster As Long, i As Long
Dim ws As Worksheet, ws2 As Worksheet, MasterEmployee As Worksheet, master As Workbook
Dim pivitem As Long
Dim vaMsg As String
Dim J As Long
Dim Whatever As String

    Call MasterEmployeelist

    Set MasterEmployee = ThisWorkbook.Worksheets("Dataset")
    Set master = ThisWorkbook
    Set PT = master.Worksheets("Plan").PivotTables("PivotTable2")

    lastrowMaster = MasterEmployee.Range("A" & Rows.Count).End(xlUp).Row

    With master.Worksheets("Plan")
        .PivotTables("PivotTable2").PivotSelect "", xlDataAndLabel, True
        .UsedRange.Copy
    End With

    Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))

    With ws
        .Name = "PlanTable"
        .Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                                                                                , SkipBlanks:=False, Transpose:=False
        .Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                           :=False, Transpose:=False

        Sheets("Monthly schedule").Range("B2:B13").Copy
        .Range("D2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                           :=False, Transpose:=True

        Call HideDates

        .Rows("1:3").Delete Shift:=xlUp
        .ListObjects.Add(xlSrcRange, Range("$A$1:$AA$493"), , xlYes).Name = _
        "Table1"
        .Range("Table1[#All]").Columns.AutoFit
    End With

    For J = 1 To lastrowMaster
        employeeName = MasterEmployee.Cells(J, 1).Text
        TrimName = Right(employeeName, Len(employeeName) - 4)

        With ws
            .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) _
                    .AutoFilter Field:=1, Criteria1:=employeeName, Operator:=xlFilterValues
            LstCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
            Lstrow = .Range("A" & Rows.Count).End(xlUp).Row
            Set copyrange = .Range("A1:AA" & Lstrow)
        End With

        copyrange.SpecialCells(xlCellTypeVisible).Copy


        vaMsg = "Hi " & TrimName & ", Below is your updated BSA allocation to projects from now until the end of the year." & vbCrLf & _
                "Please communicate with me or your respective pm(s) if this allocation does not align to your understanding." & vbCrLf & _
                "Thanks...Debbie"
        Const vaCopyTo As Variant = "name@mail.com"


        'Copy the active sheet to a new temporarily workbook.
        ws.Copy

        stFileName = employeeName
        stAttachment = stPath & "" & stFileName & ".xls"

        'Save and close the temporarily workbook.
        With ActiveWorkbook
            .Worksheets(1).Protect Password:=Whatever
            .SaveAs stAttachment
            .Close
        End With

        'Create the list of recipients.
        vaRecipients = VBA.Array("MR WHO")

        'Instantiate the Lotus Notes COM's Objects.
        Set noSession = CreateObject("Notes.NotesSession")
        Set noDatabase = noSession.GetDatabase("", "")

        'If Lotus Notes is not open then open the mail-part of it.
        If noDatabase.IsOpen = False Then noDatabase.OPENMAIL

        'Create the e-mail and the attachment.
        Set noDocument = noDatabase.CreateDocument
        Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
        Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)

        'Add values to the created e-mail main properties.
        With noDocument
            .Form = "Memo"
            .SendTo = vaRecipients
            .CopyTo = vaCopyTo
            .Subject = stSubject
            .Body = vaMsg
            .SaveMessageOnSend = True
            .PostedDate = Now()
            .Send 0, vaRecipients
        End With

        'Delete the temporarily workbook.
        Kill stAttachment

        'Release objects from memory.
        Set noEmbedObject = Nothing
        Set noAttachment = Nothing
        Set noDocument = Nothing
        Set noDatabase = Nothing
        Set noSession = Nothing

        ws.AutoFilterMode = False

    Next J

    MsgBox "The e-mail has successfully been created and distributed", vbInformation
    ThisWorkbook.Close SaveChanges:=False

End Sub

PS What do the EmployeeList and HideDates do?

 

[MagicalHippo]

You could start by getting rid of all the Activate/Select stuff.

Option Explicit

Const EMBED_ATTACHMENT As Long = 1454
Const stPath As String = "c:\Attachments"
Const stSubject As String = "Weekly report"

Public copyrange As Range
Public employeeName As String
Public TrimName As String, EmailName As String

Sub Copyvalue()
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim PT As Excel.PivotTable
Dim stFileName As String
Dim vaRecipients As Variant
Dim stAttachment As String
Dim rng As Range, Dn As Range
Dim Lstrow As Long, n As Long, LstCol As Long, lastrowMaster As Long, i As Long
Dim ws As Worksheet, ws2 As Worksheet, MasterEmployee As Worksheet, master As Workbook
Dim pivitem As Long
Dim vaMsg As String
Dim J As Long
Dim Whatever As String

    Call MasterEmployeelist

    Set MasterEmployee = ThisWorkbook.Worksheets("Dataset")
    Set master = ThisWorkbook
    Set PT = master.Worksheets("Plan").PivotTables("PivotTable2")

    lastrowMaster = MasterEmployee.Range("A" & Rows.Count).End(xlUp).Row

    With master.Worksheets("Plan")
        .PivotTables("PivotTable2").PivotSelect "", xlDataAndLabel, True
        .UsedRange.Copy
    End With

    Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))

    With ws
        .Name = "PlanTable"
        .Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                                                                                , SkipBlanks:=False, Transpose:=False
        .Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                           :=False, Transpose:=False

        Sheets("Monthly schedule").Range("B2:B13").Copy
        .Range("D2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                           :=False, Transpose:=True

        Call HideDates

        .Rows("1:3").Delete Shift:=xlUp
        .ListObjects.Add(xlSrcRange, Range("$A$1:$AA$493"), , xlYes).Name = _
        "Table1"
        .Range("Table1[#All]").Columns.AutoFit
    End With

    For J = 1 To lastrowMaster
        employeeName = MasterEmployee.Cells(J, 1).Text
        TrimName = Right(employeeName, Len(employeeName) - 4)

        With ws
            .Range("A1", .Range("A" & .Rows.Count).End(xlUp)) _
                    .AutoFilter Field:=1, Criteria1:=employeeName, Operator:=xlFilterValues
            LstCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
            Lstrow = .Range("A" & Rows.Count).End(xlUp).Row
            Set copyrange = .Range("A1:AA" & Lstrow)
        End With

        copyrange.SpecialCells(xlCellTypeVisible).Copy


        vaMsg = "Hi " & TrimName & ", Below is your updated BSA allocation to projects from now until the end of the year." & vbCrLf & _
                "Please communicate with me or your respective pm(s) if this allocation does not align to your understanding." & vbCrLf & _
                "Thanks...Debbie"
        Const vaCopyTo As Variant = "name@mail.com"


        'Copy the active sheet to a new temporarily workbook.
        ws.Copy

        stFileName = employeeName
        stAttachment = stPath & "" & stFileName & ".xls"

        'Save and close the temporarily workbook.
        With ActiveWorkbook
            .Worksheets(1).Protect Password:=Whatever
            .SaveAs stAttachment
            .Close
        End With

        'Create the list of recipients.
        vaRecipients = VBA.Array("MR WHO")

        'Instantiate the Lotus Notes COM's Objects.
        Set noSession = CreateObject("Notes.NotesSession")
        Set noDatabase = noSession.GetDatabase("", "")

        'If Lotus Notes is not open then open the mail-part of it.
        If noDatabase.IsOpen = False Then noDatabase.OPENMAIL

        'Create the e-mail and the attachment.
        Set noDocument = noDatabase.CreateDocument
        Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
        Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)

        'Add values to the created e-mail main properties.
        With noDocument
            .Form = "Memo"
            .SendTo = vaRecipients
            .CopyTo = vaCopyTo
            .Subject = stSubject
            .Body = vaMsg
            .SaveMessageOnSend = True
            .PostedDate = Now()
            .Send 0, vaRecipients
        End With

        'Delete the temporarily workbook.
        Kill stAttachment

        'Release objects from memory.
        Set noEmbedObject = Nothing
        Set noAttachment = Nothing
        Set noDocument = Nothing
        Set noDatabase = Nothing
        Set noSession = Nothing

        ws.AutoFilterMode = False

    Next J

    MsgBox "The e-mail has successfully been created and distributed", vbInformation
    ThisWorkbook.Close SaveChanges:=False

End Sub

PS What do the EmployeeList and HideDates do?

Thank you for the quick response! I was working on slowly eliminating the "Activate/ Selects" as I know this is bad way to code. I am going to slowly code in Sheet references or something similar to make it easier. The Employee list basically looks at a Hidden table, and copies all the Names from Column A into a new sheet, then I analyze for keywords in Column A, and delete those rows to leave me with my Unique Employee list.

Here is the code for Sorting, filtering, and deleting rows from copied employee list:

Sub MasterEmployeelist()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim mystring As String
ThisWorkbook.Worksheets("Filtered source").Activate
Range("A2", Cells(Rows.Count, "A").End(xlUp)).Copy
Set ws = Sheets.Add(After:=Sheets(Worksheets.Count))
ws.Name = "Dataset"
Range("A1").Activate
ws.PasteSpecial

Application.Selection.RemoveDuplicates Columns:=1, Header:=xlNo
With ws.Range("A1:A" & CStr(Range("A" & Rows.Count).End(xlUp).Row))
    .Replace "*unallocated*", "#NAME?", xlWhole, xlByRows, False
    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete xlUp
    .Replace "*no entry*", "#NAME?", xlWhole, xlByRows, False
    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete xlUp
End With

The Hide Dates Macro, basically looks at a row above my pasted table in "PlanTable" and uses these rows to hide Columns that have past. That way when I email, I only show the employees their specific hours allocated for this Month (October) going through to end of year.

Here is the code for my HideDates below as well:

Sub HideDates()
 Dim rng As Range, rng2 As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("PlanTable")
With ws
 Set rng = [D2]
 Do While rng.Value <> Empty
     If rng.Value < Date Then
         rng.EntireColumn.Hidden = True
     End If
     
 Set rng = rng.Offset(0, 1)
 Loop
 End With
End Sub

 

[Norie]

Have you checked which parts of the code are taking the most time?

 

[MagicalHippo]

Have you checked which parts of the code are taking the most time?

My best guess is the fact that I have 60 employees to loop through, and each range contains about 10 rows of data per employee. I think the complexity comes with integrating my Code and Opening Lotus Emails, I would say it slows down there as I am looping through the email application at every iteration of Employee Name

 

[Norie]

Have you tried stepping through the code with F8?

That should help you find if there is any specific 'bottleneck' in the code.

By the way, if the problem is with opening Lotus and sending the emails then there might no be much you can do about it.

Actually, when I think about it if that is the problem then there could be something you can do about it - don't instantiate an instance/session of Lotus Notes for each individual email.

That might be as easy to fix as putting this outside the loop.

        Set noSession = CreateObject("Notes.NotesSession")
        Set noDatabase = noSession.GetDatabase("", "")

 

[MagicalHippo]

Have you tried stepping through the code with F8?

That should help you find if there is any specific 'bottleneck' in the code.

By the way, if the problem is with opening Lotus and sending the emails then there might no be much you can do about it.

Actually, when I think about it if that is the problem then there could be something you can do about it - don't instantiate an instance/session of Lotus Notes for each individual email.

That might be as easy to fix as putting this outside the loop.

        Set noSession = CreateObject("Notes.NotesSession")
        Set noDatabase = noSession.GetDatabase("", "")

The only issue with putting the above code outside the loop, is that inside the loop, the Lotus App references the noSession and noDatabase variables to create an email, I just tried running with your suggestion and it crashed.

 

[Norie]

Those variables will still be available in the loop.

There is something else you'll need to do though, try moving this after the loop.

Set noDatabase = Nothing
Set noSession = Nothing

 

[MagicalHippo]

Those variables will still be available in the loop.

There is something else you'll need to do though, try moving this after the loop.

Set noDatabase = Nothing
Set noSession = Nothing

Ahh just noticed what was going on, thanks! Time to look at what more I can do now to make this run quickly, I do appreciate the help Norie. This was fairly advanced for me to code correctly. I'm just curious what would this be considered on a level of beginner, intermediate, advanced?

 

[MagicalHippo]

Those variables will still be available in the loop.

There is something else you'll need to do though, try moving this after the loop.

Set noDatabase = Nothing
Set noSession = Nothing

Hi Norie,

I think I am running into a small bug here. For some reason this program will run and send emails. However, the emails only show up in the Inbox, when I click "Sent folder." Otherwise, they do not show up.... :S