Split worksheet into tabs then email

[Shelley2018]

Hi everybody, I hope someone can help with a code for this please?

In the example below, I would like to split a worksheet at each change in the Location column so that the data goes into a new sheet of the same workbook, then email each new tab to the relevant email in cell E2 using Outlook.

I’ve tried using the responses to other similar questions and sort of got it to work but not quite. I am also struggling with the email it defaults from – I changed my default email in Outlook first but it was still going from my previously set default email. Is there any way to specify which email account it comes from? Would it also be possible to add a total to the cost column once it goes into a new tab? This isn't essential so ignore this if its faffy

Thank you

[TABLE="class: grid, width: 407, align: left"]
<tbody>[TR]
[TD]Name[/TD]
[TD]DOB[/TD]
[TD]Location[/TD]
[TD]Cost[/TD]
[TD]Email[/TD]
[/TR]
[TR]
[TD]A Jones[/TD]
[TD="align: right"]01/02/1977[/TD]
[TD]London[/TD]
[TD="align: right"]12[/TD]
[TD]me@myemail.com[/TD]
[/TR]
[TR]
[TD]B Jones[/TD]
[TD="align: right"]02/02/1988[/TD]
[TD]London[/TD]
[TD="align: right"]14[/TD]
[TD]me@myemail.com[/TD]
[/TR]
[TR]
[TD]C Davis[/TD]
[TD="align: right"]03/05/1966[/TD]
[TD]Manchester[/TD]
[TD="align: right"]144[/TD]
[TD]me1@myemail.com[/TD]
[/TR]
[TR]
[TD]D Taylor[/TD]
[TD="align: right"]02/06/1933[/TD]
[TD]Manchester[/TD]
[TD="align: right"]13[/TD]
[TD]me1@myemail.com[/TD]
[/TR]
[TR]
[TD]E Jones[/TD]
[TD="align: right"]03/04/1933[/TD]
[TD]Birmingham[/TD]
[TD="align: right"]15[/TD]
[TD]me2@myemail.com[/TD]
[/TR]
[TR]
[TD]F Smith[/TD]
[TD="align: right"]04/05/1965[/TD]
[TD]Birmingham[/TD]
[TD="align: right"]56[/TD]
[TD]me2@myemail.com[/TD]
[/TR]
[TR]
[TD]G Smith[/TD]
[TD="align: right"]03/04/1934[/TD]
[TD]Birmingham[/TD]
[TD="align: right"]4[/TD]
[TD]me2@myemail.com[/TD]
[/TR]
</tbody>[/TABLE]

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub CopyFltr()
   Dim ws As Worksheet
   Dim Cl As Range
   
   Application.ScreenUpdating = False
   Set ws = Sheets("[COLOR=#ff0000]pcode[/COLOR]")
   If ws.AutoFilterMode Then ws.AutoFilterMode = False
   With CreateObject("Scripting.dictionary")
      For Each Cl In ws.Range("C2", ws.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            ws.Range("[COLOR=#ff0000]A1:Q1[/COLOR]").AutoFilter 3, Cl.Value
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            ws.AutoFilter.Range.Copy Sheets(Cl.Value).Range("A1")
            Sheets(Cl.Value).Range("D" & Rows.Count).End(xlUp).Offset(1).FormulaR1C1 = "=sum(r2c:r[-1]c)"
         End If
      Next Cl
   End With
   ws.AutoFilterMode = False
End Sub

Change values in red to suit.
This will create the new sheets & add the total.
I can't help with the email side as I don't have Outlook, but have a look here https://www.rondebruin.nl/win/s1/outlook/mail.htm

 

[Shelley2018]

Thank you very much for that, it works well. Please could you tell me if there is a way to make it autofit the column widths in the new tabs?

 

[Fluff]

Add the line in blue

Sub CopyFltr()
   Dim ws As Worksheet
   Dim Cl As Range
   
   Application.ScreenUpdating = False
   Set ws = Sheets("pcode")
   If ws.AutoFilterMode Then ws.AutoFilterMode = False
   With CreateObject("Scripting.dictionary")
      For Each Cl In ws.Range("C2", ws.Range("C" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            ws.Range("A1:Q1").AutoFilter 3, Cl.Value
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            ws.AutoFilter.Range.Copy Sheets(Cl.Value).Range("A1")
            Sheets(Cl.Value).Range("D" & Rows.Count).End(xlUp).Offset(1).FormulaR1C1 = "=sum(r2c:r[-1]c)"
            [COLOR=#0000ff]Sheets(Cl.Value).Columns.AutoFit[/COLOR]
         End If
      Next Cl
   End With
   ws.AutoFilterMode = False
End Sub

 

[Shelley2018]

Wonderful, thank you

 

[Fluff]

Glad to help & thanks for the feedback