Macro to create and email multiple emails to specified email

[cherry_pie]

Good day and thank you in advance for your help.

I have a very basic understanding of Macros and this is on of the first times I have written code (to me) this complicated. I have cobbled together some things I have found online but it isn't working yet.

I am trying to rewrite some existing code (that creates multiple files depending on who the lines are assigned to) to also email those files out after saving them before moving to the next.

I have copied the entire macro text at the bottom (I can edit this out if this is pointless, let me know).

My questions are as follows:

1 - when the files are created it also creates extra files which I don't need. One named "(blank) [date]" and one just [date]. It then tries to repeatedly create the just [date] one. I presume this is due to extra lines from the pivot table being picked up as it also previously picked up the subtotal line, but I removed this, but I can't get rid of the blank line or stop it continuing until I stop.

2 - My code is not right for sending the email. I have defined a "Dim" EmailAddress at the top of the code and then the following lines to lookup the email address in a separate file. I'm presuming this is not the right way to write it as it doesn't work, but I have no idea how to fix it. Does the file need to be open for it to look up the address, or can it be closed?

EmailAddress = VLookup(PersonLab, "C:\Users\Name\Desktop\Macro Testing\EmailsAdds.xlsx", 2, 0)
.To = EmailAddress


3 - I have multiple mailboxes in my outlook which I am able to send emails from. I want to make sure it uses a specific one (for example ABC@ABC.co.uk ) . I have added the following code:

.SentOnBehalfOfName = ABC@ABC.co.uk

Is this the correct way of doing it?

I hope these changes will fix it

Once again, Thank you so much for your help in advance
Hannah




Sub Create_Dashboards()
'
' Create_dashboard_file Macro
' Macro to create an individual PersonLab's file for approval.
'

'
Dim PersonLab
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddress

Application.ScreenUpdating = False

'From Pivot tab, refresh pivot table
Sheets("Pivot").Select
Range("A14").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh

'Create filter on Data tab
Sheets("Data").Select
Rows("1:1").Select
Selection.AutoFilter

'Set PersonLab as first on pivot list
Sheets("Pivot").Select
Z = Sheets("Pivot").UsedRange.Rows.Count
For i = 4 To Z + 1
PersonLab = Sheets("Pivot").Range("A" & i)

'Filter on data using PersonLab as reference
Sheets("Data").Select
N = Sheets("Data").UsedRange.Rows.Count
ActiveSheet.Range("A1" & ":" & "Z" & N).AutoFilter Field:=23, Criteria1:=PersonLab

'Copy all rows of filtered data
Rows("1:" & N).Select
Application.CutCopyMode = False
Selection.Copy

'Create new file and paste copied data. Freeze top row and add a filter.
Workbooks.Add
ActiveSheet.Paste
Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Columns("T:W").Select
Selection.Delete Shift:=xlToLeft
Cells.Select
Cells.EntireColumn.AutoFit
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Selection.AutoFilter
Range("A2").Select

'Save file using PersonLab and date.
ChDir "C:\Users\Name\Desktop\Macro Testing\"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\Name\Desktop\Macro Testing\" & PersonLab & " " & Format(Date, "DD-MM-YYYY") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

'Email file using Outlook


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

On Error Resume Next
With OutMail
EmailAddress = VLookup(PersonLab, "C:\Users\Name\Desktop\Macro Testing\EmailsAdds.xlsx", 2, 0)
.To = EmailAddress
.Subject = "Testing Email" & Format(Date, "DD-MM-YYYY")
.Body = "will figure this out if this works"
.Importance = 2
.SentOnBehalfOfName = ABC@ABC.co.uk
.ReadReceiptRequested = True
.Attachments.Add ActiveWorkbook.FullName


.Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing


Windows(PersonLab & " " & Format(Date, "DD-MM-YYYY") & ".xlsx").Close

'Go back to Main file
Windows("TestMacro.xlsm").Activate
Next i

'Remove filter
Sheets("Data").Select
Rows("1:1").Select
Selection.AutoFilter

End Sub

 

[cherry_pie]

Any thoughts?