jark
10-04-2016, 10:46 AM
Hello I am looking for a way to better Optimize my Code below. I have it programmed to Filter a Table against a list of names in Column A of Master sheet. Each Name has a filtered table associated to it, each table is copied into a workbook, and attached via Lotus Email. From there, I send the email, and Loop over again to the next Employee Name. I am wondering how to make this faster? I thought of applying Employee names into an Array, and also copying my Ranges into an Array then just dumping the Array back out into multiple emails...
Here's my code! Hope you guys can help!
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 & "," & vbCrLf & _
vbCrLf & _
"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 & _
vbCrLf & _
"Thanks...Debbie"
Const vaCopyTo As Variant =""
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:=Batman
.SaveAs stAttachment
.Close
End With
'Create the list of recipients.
vaRecipients = VBA.Array("Batman")
'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
End Sub
Here's my code! Hope you guys can help!
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 & "," & vbCrLf & _
vbCrLf & _
"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 & _
vbCrLf & _
"Thanks...Debbie"
Const vaCopyTo As Variant =""
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:=Batman
.SaveAs stAttachment
.Close
End With
'Create the list of recipients.
vaRecipients = VBA.Array("Batman")
'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
End Sub