Split Specific Sheets into New Excel Workbook and email to different people

[Excel2021]

Hello,

I have an Excel Workbook with 30 sheets and I would like to select specific sheets and turn them into new Workbooks which will then get sent out to specific people via email. Is this possible via VBA?


As an example, say I had a workbook with the following sheet names:

AppleUSD
AppleCAD
AppleGBP
OrangeUSD
OrangeCAD
OrangeGBP

I would like 2 seperate workbooks to be created automatically. 1) called "Apple" which would includes the 3 Apple sheets above and 2) called "Orange" which includes the 3 Orange sheets above.

if possible, next, I would like the newly created "Apple" Workbook to be sent with the email title "Apple" and the message saying "Please see the Attached file" to Bb@gmail.com and Ss@gmail.com. Similarly I would like the "Orange" workbook sent to PL@gmail.com and cc GD@gmail.com with the email title "Orange" and the message saying "Please see the Attached file".


Thanks in advance.

 

[Excel2021]

You mentioned that you need to do this for 13 sheets. You can use this for as many sheets and workbooks as you want. All with one macro.
If you have the email addresses in Sheet2 in the first 13 columns (A to M) from the 2nd Row on down in the same order as the shArr items.
Cell A1 would have "Apple". From Cell A2 on down would be email addresses for the people that get the Apple Workbook emailed.
Cell B1 would have "Orange". From Cell B2 on down would be email addresses for the people that get the Orange Workbook emailed.
Cell C1 would have "Pear". From Cell C2 on down would be email addresses for the people that get the Pear Workbook emailed.
Continue like this for all email addresses and workbook names.
The following code will save the required workbooks to the same Folder where this Workbook is saved.
It will also email the workbooks to the required recipients.
Note: If a workbook exists with the same name in that same folder, it will be deleted and replaced by the new workbook.
Try it with using your own email address first to ensure that it gives you the needed amounts.

Sub One_Macro_For_All()
Dim shArr
Dim snArr
Dim sh As Worksheet, sh2 As Worksheet, currSh As Worksheet
Dim i As Long, j As Long, jj As Long
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set currSh = ActiveSheet
Set sh2 = Worksheets("Sheet2")
shArr = Array("Apple", "Orange", "Pear")    '<---- Sheet names start with this. extend with as many as required
jj = 1
Application.ScreenUpdating = False
    For i = LBound(shArr) To UBound(shArr)
        For Each sh In ThisWorkbook.Worksheets
            If Left(sh.Name, Len(shArr(i))) = shArr(i) Then snArr = snArr & "|" & sh.Name
        Next sh
        snArr = Split(Mid(snArr, 2), "|")
        Sheets(snArr).Select
        ActiveWorkbook.Windows(1).SelectedSheets.Copy
    With ActiveWorkbook
        If Dir(ThisWorkbook.Path & "\" & shArr(i) & " Sheets.xlsx") <> "" Then
            Kill ThisWorkbook.Path & "\" & shArr(i) & " Sheets.xlsx"
        End If
        .SaveAs ThisWorkbook.Path & "\" & shArr(i) & " Sheets.xlsx", 51    'xlsm = 52
        For j = 2 To sh2.Cells(sh2.Rows.Count, jj).End(xlUp).Row
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = sh2.Cells(j, jj).Value  
                .CC = ""
                .BCC = ""
                .Subject = "See " & ActiveWorkbook.Name     '"See Attached"
                .body = ""
                .Attachments.Add ActiveWorkbook.FullName
                .send
            End With
            DoEvents
            Next j
            j = 0
        .Close True
    End With
    snArr = ""
    jj = jj + 1
    Next i
currSh.Select
End Sub

Thanks, I can try this later but Trevor's code is working well for me so far.

 

[Excel2021]

You mentioned that you need to do this for 13 sheets. You can use this for as many sheets and workbooks as you want. All with one macro.
If you have the email addresses in Sheet2 in the first 13 columns (A to M) from the 2nd Row on down in the same order as the shArr items.
Cell A1 would have "Apple". From Cell A2 on down would be email addresses for the people that get the Apple Workbook emailed.
Cell B1 would have "Orange". From Cell B2 on down would be email addresses for the people that get the Orange Workbook emailed.
Cell C1 would have "Pear". From Cell C2 on down would be email addresses for the people that get the Pear Workbook emailed.
Continue like this for all email addresses and workbook names.
The following code will save the required workbooks to the same Folder where this Workbook is saved.
It will also email the workbooks to the required recipients.
Note: If a workbook exists with the same name in that same folder, it will be deleted and replaced by the new workbook.
Try it with using your own email address first to ensure that it gives you the needed amounts.

Sub One_Macro_For_All()
Dim shArr
Dim snArr
Dim sh As Worksheet, sh2 As Worksheet, currSh As Worksheet
Dim i As Long, j As Long, jj As Long
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set currSh = ActiveSheet
Set sh2 = Worksheets("Sheet2")
shArr = Array("Apple", "Orange", "Pear")    '<---- Sheet names start with this. extend with as many as required
jj = 1
Application.ScreenUpdating = False
    For i = LBound(shArr) To UBound(shArr)
        For Each sh In ThisWorkbook.Worksheets
            If Left(sh.Name, Len(shArr(i))) = shArr(i) Then snArr = snArr & "|" & sh.Name
        Next sh
        snArr = Split(Mid(snArr, 2), "|")
        Sheets(snArr).Select
        ActiveWorkbook.Windows(1).SelectedSheets.Copy
    With ActiveWorkbook
        If Dir(ThisWorkbook.Path & "\" & shArr(i) & " Sheets.xlsx") <> "" Then
            Kill ThisWorkbook.Path & "\" & shArr(i) & " Sheets.xlsx"
        End If
        .SaveAs ThisWorkbook.Path & "\" & shArr(i) & " Sheets.xlsx", 51    'xlsm = 52
        For j = 2 To sh2.Cells(sh2.Rows.Count, jj).End(xlUp).Row
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = sh2.Cells(j, jj).Value  
                .CC = ""
                .BCC = ""
                .Subject = "See " & ActiveWorkbook.Name     '"See Attached"
                .body = ""
                .Attachments.Add ActiveWorkbook.FullName
                .send
            End With
            DoEvents
            Next j
            j = 0
        .Close True
    End With
    snArr = ""
    jj = jj + 1
    Next i
currSh.Select
End Sub

I ended up trying to use your code as I was thinking it might pain to change the macro each time I wanted to change the save location but I was getting a VBA error saying that it couldn't copy a sheet with a table on it.

Also, I would need a way to create a new workbook with all sheets that have USA, UK or CAN in the filename in addition.

Thanks

 

[jolivanes]

Re: "sheets that have USA, UK or CAN in the filename" Do you mean sheetname?
I don't know the first thing about tables. Is it OK to change to non table?

Please, please, please. Don't Quote. Refer to Post Numbers instead

 

[Excel2021]

Re: "sheets that have USA, UK or CAN in the filename" Do you mean sheetname?
I don't know the first thing about tables. Is it OK to change to non table?

Please, please, please. Don't Quote. Refer to Post Numbers instead

No, I need the sheets to remain in table form. I will continue usung the original code I was given as it was working for this.

 

[Trevor G]

If you save your logo to a specific location/folder you can add it by using an insert image something like this (remove the extra quotes to show the tags in the forum. Change the path and logo name as necessary).

 .HTMLBody = what every you've added so far & "<br></br>" & "<img src=""C:\Users\Desktop\Logo.bmp"">

Or the alternative would be to insert the signature once the email is displayed, but if you want to send the email direct then look to use the insert image tag.

 

[Excel2021]

If you save your logo to a specific location/folder you can add it by using an insert image something like this (remove the extra quotes to show the tags in the forum. Change the path and logo name as necessary).

 .HTMLBody = what every you've added so far & "<br></br>" & "<img src=""C:\Users\Desktop\Logo.bmp"">

Or the alternative would be to insert the signature once the email is displayed, but if you want to send the email direct then look to use the insert image tag.

Thanks I will try this. I was also wondering if it were possible to have the save location of the new workbooks take on whichever folder the main file is in rather than manually defining them? I would like the file to put the workbooks in the same folder as the main file if possible as I may have to share the file and the macro could be run in different folders potentially.

 

[Trevor G]

You could look at using the path as the same as the workbook your running the code from so that line would be, saving the workbook line and email attachment line in your code:

Thisworkbook.path & "\" & "the name of the new file.xlsx"
And this would be the same line in the email attachment

Hope this helps.

 

[Excel2021]

You could look at using the path as the same as the workbook your running the code from so that line would be, saving the workbook line and email attachment line in your code:

Thisworkbook.path & "\" & "the name of the new file.xlsx"
And this would be the same line in the email attachment

Hope this helps.

Thanks, this almost works but it will add "%20" in between every word of the file name on the email attachment. For example, if my file name was "NA Oranges & Apples" it would save the file as "NA Oranges & Apples" in the correct folder but the email attachment would appears as NA%20Oranges%20&%20Apples.

Thanks

 

[Excel2021]

Thanks, this almost works but it will add "%20" in between every word of the file name on the email attachment. For example, if my file name was "NA Oranges & Apples" it would save the file as "NA Oranges & Apples" in the correct folder but the email attachment would appears as NA%20Oranges%20&%20Apples.

Thanks

Just to add to my reply, all my files are automatically backed up to SharePoint as they save. It looks like the VBA is pulling the sharepoint file path rather than the desktop when it attaches the file to the email.

 

[Trevor G]

I don't attach files via SharePoint but have read you could try using the replace statement. I haven't tested this:

.Attachments.Add(ThisWorkbook.Path & "\" & "the name of the new file.xlsx") = Replace(ThisWorkbook.Path & "\" & "the name of the new file.xlsx", "&20", " ")