Emailing reports based on multiple drop down box conditions

[soconfused365]

Hi all,

I am incredibly confused here!

I have a workbook with a sheet for each month of the year Jan,Feb,Mar etc and in each one is multiple names in column A over and over (lots of other info in the other columns but its all related to the column A name). I have a reporting tab and from that I need to have 2 buttons - one send to all and 1 send to specific

Specific - I need to unprotect the sheet for the month that is selected in the drop down box, filter it to the persons name in the 2nd drop down box, copy that filtered worksheet to another workbook on its own, lock it again so they cant see the other information in there and then email it to them

Send to all - Same as above but it does 1 after the other of all the names within the list

I have a lookups sheet with each of their names next to their email address. I do not need to save the resulting sheets. All sheets have the same password to unprotect. All possible names are within the list and there is no variance on them. Same with the months drop down - they are exactly the same as the tabs.

Message within the email body also needs to refer to the month drop down eg Hi *NAME* Please see attached *Jan*

I have found lots of little bits that can do 1 of these jobs but then when I try and put them all together it goes all higgledy-piggledy so any help would be greatly appreciated! On the latest updating 365 version and if you need to know anything else just ask!

 

[kevin9999]

What you're asking for is very possible, however, I wouldn't be prepared to even start on this until I saw what your "reporting tab" looks like, and a sample of one of your month sheets. This forum has the XL2BB Tool which enables you to provide samples of your sheets. You can disguise any personal/sensitive information if needed.

 

[soconfused365]

What you're asking for is very possible, however, I wouldn't be prepared to even start on this until I saw what your "reporting tab" looks like, and a sample of one of your month sheets. This forum has the XL2BB Tool which enables you to provide samples of your sheets. You can disguise any personal/sensitive information if needed.

tester.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	Name	Date	Time 1	Time 2	Time 3	Time 4	Thing 1	Thing 2	Thing 3	Thing 4	Thing 5	Thing 6	Total Things	Thing 1	Thing 2	Thing 3	Thing 4	Thing 5	Thing 6	Total things	Final calc
2	Thunderbirds	01/01/2022	6	2	120	1	21		4	2			27	168	0	44	8	0	0	220	183.33%
3	Stingray		7	8	420		43	3					46	344	21	0	0	0	0	365	86.90%
4	Scarlet		4		240				8		9		17	0	0	88	0	81	0	169	70.42%
5	Thunderbirds	03/01/2022	6	2	360	8		5		5		22	32	0	35	0	20	0	22	77	21.39%
6	Stingray		3		180		68		9	7			84	544	0	99	28	0	0	671	372.78%
7	Scarlet		4	8	240			7			9		16	0	49	0	0	81	0	130	54.17%
8	Thunderbirds	04/01/2022	7		420		5			8			13	40	0	0	32	0	0	72	17.14%
9	Stingray		9		540	3	8		2			45	55	64	0	22	0	0	45	131	24.26%
10	Scarlet		3	4	180	3		8		3			11	0	56	0	12	0	0	68	37.78%
11	Thunderbirds	05/01/2022	8		480			2	7		9		18	0	14	77	0	81	0	172	35.83%
12	Stingray		8		480	7	9			5			14	72	0	0	20	0	0	92	19.17%
13	Scarlet		2		120		3					29	32	24	0	0	0	0	29	53	44.17%
14	Thunderbirds	06/01/2022	7	2	420			7	1		4		12	0	49	11	0	36	0	96	22.86%
15	Stingray		3		180		4			7			11	32	0	0	28	0	0	60	33.33%
16	Scarlet		8		480			2			23		25	0	14	0	0	207	0	221	46.04%
17	Thunderbirds	07/01/2022	10		600	22			5	9			14	0	0	55	36	0	0	91	15.17%
18	Stingray		2		120		8	5	7				20	64	35	77	0	0	0	176	146.67%
19	Scarlet		4		240			7			12		19	0	49	0	0	108	0	157	65.42%
20	Thunderbirds	10/01/2022	8		480	8		9				21	30	0	63	0	0	0	21	84	17.50%
21	Stingray		3		180				8		9		17	0	0	88	0	81	0	169	93.89%
22	Scarlet		7		420		3			11			14	24	0	0	44	0	0	68	16.19%
Jan

Cell Formulas
Range	Formula
M2:M22,T2:T22	M2	=SUM(G2:L2)
N2:N22	N2	=G2*Lookups!$B$1
O2:O22	O2	=H2*Lookups!$B$2
P2:P22	P2	=I2*Lookups!$B$3
Q2:Q22	Q2	=J2*Lookups!$B$4
R2:R22	R2	=K2*Lookups!$B$5
S2:S22	S2	=L2*Lookups!$B$6
U2:U22	U2	=T2/E2
B5,B20,B17,B14,B11,B8	B5	=WORKDAY(B2,1)
E2	E2	=C2*20
E3:E22	E3	=C3*60

tester.xlsx
	A	B	C	D	E	F	G
1	Thing 1	8				Jan
2	Thing 2	7				Feb
3	Thing 3	11				Mar
4	Thing 4	4				Apr
5	Thing 5	9				May
6	Thing 6	1				Jun
7						Jul
8						Aug
9						Sept
10	Thunderbirds	thirdbirds@arego.com				Oct
11	Stingray	stingray@stingray.co.uk				Nov
12	Scarlet	scarlet@captain.com				Dec
13
14
15
Lookups

tester.xlsx
	A	B	C	D	E	F	G	H	I
1	Report 1
2
3		Button to activate an exisiting Macro
4
5
6
7	Report 2
8
9		Button to activate an exisiting Macro
10
11
12
13
14	Reports I need help with
15					Button here to run the to all
16	Month
17
18	Name
19
20
21	Button here to run the single
22
23
24
Reporting

Cells with Data Validation
Cell	Allow	Criteria
C16	List	=Lookups!$F$1:$F$12
C18	List	=Lookups!$A$10:$A$12

Anything in Yellow is typed in or selected from a drop down box. Oh I did also remember that at the end the sheets will need reprotecting with the same password - thank you so so much! If there is anything more you need let me know

 

[kevin9999]

Thanks for that - leave it with me

 

[kevin9999]

OK, this might take a bit of back & forth. This first code is to send an individual sheet to one person. To test it, make sure you have a valid email address next to the person you select. Once we get this right, we'll go onto the multiple emails version.
EDIT - forgot the protect/unprotect part.

Option Explicit
Sub soconfused365_1()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim NameRng As Range, c As Range, wb As Workbook, lr As Long
    Dim RepMonth As String, EmailTo As String, EmailAddress As String

    Set ws1 = Worksheets("Reporting")
    Set ws2 = Worksheets("Lookups")
    Set NameRng = ws2.Range("A10", ws2.Cells(Rows.Count, "A").End(xlUp))

    'Get names and month variables
    RepMonth = ws1.Range("C16")
    EmailTo = ws1.Range("C18")

    'Ensure no blank variables
    If Len(RepMonth) = 0 Or Len(EmailTo) = 0 Then
        MsgBox "Select a valid month and name"
        Exit Sub
    End If

    'Get the email address and the report sheet name
    EmailAddress = NameRng.Cells(Application.Match(EmailTo, NameRng, 0), 1).Offset(, 1)
    Set ws3 = Worksheets(RepMonth)
    ws3.Unprotect "password"
    
    'Copy the month sheet to a new workbook
    ws3.Copy: Set ws4 = ActiveWorkbook.Sheets(1)
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & RepMonth & ".xlsx"
    ws3.Protect "password"
    
    'Unmerge cells & fill in dates
    ws4.Cells.UnMerge
    lr = ws4.Cells(Rows.Count, 1).End(3).Row
    For Each c In ws4.Range("B2:B" & lr)
        If c = "" Then c = c.Offset(-1)
    Next c

    'Set the filter on the month sheet - delete all other records
    With ws4.Cells(1).CurrentRegion
        .AutoFilter 1, "<>" & EmailTo
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With
    ActiveWorkbook.Save

    'Email the individual report
    Dim OutApp As Object, OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = EmailAddress
        .Subject = RepMonth & " Report attached"
        .Body = "Hi " & EmailTo & vbNewLine & "Please see attached " & RepMonth
        .Attachments.Add ActiveWorkbook.FullName
        .Send
    End With

    'Delete the individual report
    ActiveWorkbook.Close 0
    Kill ThisWorkbook.Path & "\" & RepMonth & ".xlsx"

End Sub

 

[soconfused365]

Wow that worked 99% immediately!!!!

Seems like it needs a copy and paste in there somewhere as it is throwing N/As on the recipient's screen in some of the formulas

The filtering and email all worked perfectly!

 

[kevin9999]

Wow that worked 99% immediately!!!!

Seems like it needs a copy and paste in there somewhere as it is throwing N/As on the recipient's screen in some of the formulas

The filtering and email all worked perfectly!

Thanks for the feedback. Slight addition to the code, try this:

Option Explicit
Sub soconfused365_2()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim NameRng As Range, c As Range, wb As Workbook, lr As Long
    Dim RepMonth As String, EmailTo As String, EmailAddress As String

    Set ws1 = Worksheets("Reporting")
    Set ws2 = Worksheets("Lookups")
    Set NameRng = ws2.Range("A10", ws2.Cells(Rows.Count, "A").End(xlUp))

    'Get names and month variables
    RepMonth = ws1.Range("C16")
    EmailTo = ws1.Range("C18")

    'Ensure no blank variables
    If Len(RepMonth) = 0 Or Len(EmailTo) = 0 Then
        MsgBox "Select a valid month and name"
        Exit Sub
    End If

    'Get the email address and the report sheet name
    EmailAddress = NameRng.Cells(Application.Match(EmailTo, NameRng, 0), 1).Offset(, 1)
    Set ws3 = Worksheets(RepMonth)
    ws3.Unprotect "password"
    
    'Copy the month sheet to a new workbook
    ws3.Copy: Set ws4 = ActiveWorkbook.Sheets(1)
    With ws4.UsedRange
        .Value = .Value
    End With
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & RepMonth & ".xlsx"
    ws3.Protect "password"
    
    'Unmerge cells & fill in dates
    ws4.Cells.UnMerge
    lr = ws4.Cells(Rows.Count, 1).End(3).Row
    For Each c In ws4.Range("B2:B" & lr)
        If c = "" Then c = c.Offset(-1)
    Next c

    'Set the filter on the month sheet - delete all other records
    With ws4.Cells(1).CurrentRegion
        .AutoFilter 1, "<>" & EmailTo
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With
    ActiveWorkbook.Save

    'Email the individual report
    Dim OutApp As Object, OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = EmailAddress
        .Subject = RepMonth & " Report attached"
        .Body = "Hi " & EmailTo & vbNewLine & "Please see attached " & RepMonth
        .Attachments.Add ActiveWorkbook.FullName
        .Send
    End With

    'Delete the individual report
    ActiveWorkbook.Close 0
    Kill ThisWorkbook.Path & "\" & RepMonth & ".xlsx"

End Sub

 

[kevin9999]

When you're ready, you can try the following code to send the same sheet to all the recipients on your list:

Option Explicit
Sub soconfused365_multi()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim NameRng As Range, c As Range, r As Range, wb As Workbook, lr As Long
    Dim RepMonth As String, EmailTo As String, EmailAddress As String
    Application.ScreenUpdating = False
    
    Set ws1 = Worksheets("Reporting")
    Set ws2 = Worksheets("Lookups")
    Set NameRng = ws2.Range("A10", ws2.Cells(Rows.Count, "A").End(xlUp))

    'Get month variables
    RepMonth = ws1.Range("C16")
    
    'Loop through names variables
    For Each r In NameRng
    
        EmailTo = r.Value
    
        'Ensure no blank variables
        If Len(RepMonth) = 0 Or Len(EmailTo) = 0 Then
            MsgBox "Valid month and/or name missing"
            Exit Sub
        End If
    
        'Get the email address and the report sheet name
        EmailAddress = NameRng.Cells(Application.Match(EmailTo, NameRng, 0), 1).Offset(, 1)
        Set ws3 = Worksheets(RepMonth)
        ws3.Unprotect "password"
        
        'Copy the month sheet to a new workbook
        ws3.Copy: Set ws4 = ActiveWorkbook.Sheets(1)
        With ws4.UsedRange
            .Value = .Value
        End With
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & RepMonth & ".xlsx"
        ws3.Protect "password"
        
        'Unmerge cells & fill in dates
        ws4.Cells.UnMerge
        lr = ws4.Cells(Rows.Count, 1).End(3).Row
        For Each c In ws4.Range("B2:B" & lr)
            If c = "" Then c = c.Offset(-1)
        Next c
    
        'Set the filter on the month sheet - delete all other records
        With ws4.Cells(1).CurrentRegion
            .AutoFilter 1, "<>" & EmailTo
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
        ActiveWorkbook.Save
    
        'Email the individual report
        Dim OutApp As Object, OutMail As Object
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = EmailAddress
            .Subject = RepMonth & " Report attached"
            .Body = "Hi " & EmailTo & vbNewLine & "Please see attached " & RepMonth
            .Attachments.Add ActiveWorkbook.FullName
            .Send
        End With
    
        'Delete the individual report
        ActiveWorkbook.Close 0
        Kill ThisWorkbook.Path & "\" & RepMonth & ".xlsx"

    Next r
    
    Application.ScreenUpdating = True
End Sub

 

[soconfused365]

I will give these a shot in the morning and let you know how they go! Thanks again for your help

 

[soconfused365]

The single is working perfectly now thank you!

With the multiple I am getting a run time error
Outlook does not recognise 1 or more of the names. This is fed from the same list as the single ones. When I click on debug it takes me to

.Send

Right at the end under the email the individual report section

Any ideas?