Macro to email workbook to different recipients

0

I have copied a macro that splits a file into separate workbooks but it always emails to the cells in the original document and not the new workbooks. I am new to VBA so any help is much appreciated.

Sub Split_To_Workbook_and_Email()
'Working in 2013/2016
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim myOutlook As Object
    Dim myMailItem As Object
    Dim mySubject As String
    Dim myPath As String
    Dim strbody As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    Set otlApp = CreateObject("Outlook.Application")
    mySubject = "GDPR and your contacts - please read "
    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "f:\OnePlace\Strategy\GDPR\Primary Contact\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2016
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                End If
            End With
            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                    Cells.EntireColumn.AutoFit
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            With Destwb
                .Close False
            End With
            Set otlNewMail = otlApp.createitem(olMailItem)
            With otlNewMail
                strbody = "As part of GDPR requirements we need to seek approval from our contacts to market to them our events and briefings. As a result, we are currently checking in with fee-earners to confirm their contact spread at their clients." & vbNewLine & _
                "I am contacting you regarding the contacts we hold for the attached company as based on our records you have billed the client in the last 2 years. At this stage, please can you collectively review the contacts in the attached file and respond to me by COB 22/11/17 with the following information:" & vbNewLine & _
                "1.  Validating current contacts - please enter a Y/N in the relevant column to determine whether we keep should keep these contacts on the system (i.e. if you still have contact with them / they are still at the entity concerned);" & vbNewLine & _
                "2.  Primary Contact - please enter one name here which will enable you to be informed of their preferences when they reply, be informed periodically of how we are marketing to them / their interests and importantly be the primary contact for the respective individual should someone in the firm wish to follow-up with you directly about that contact; and" & vbNewLine & _
                "3.  Additions - if there are any contacts you collectively have as a team not listed here please add them, with the respective columns completed, and we will add them to OnePlace and seek approvals for them on your behalf." & vbNewLine & _
                "If you have any questions please contact gdprcompliance@dacbeachcroft.com" & vbNewLine & vbNewLine & _
                "Kind regards " & vbNewLine
                .Subject = mySubject
                .Body = strbody
                .to = ActiveSheet.Range("m2")
                .SentOnBehalfOfName = """GDPRcompliance"" <GDPRcompliance@dacbeachcroft.com>"
                .Attachments.Add myPath
                .Display
            End With
            Set otlNewMail = Nothing
        End With
        End If
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
Post Edited
CODE Tags: You must add [CODE][/CODE] tags around your code! (click the CODE button to do this when creating a post)
Answer
Discuss

Answers

0
Selected Answer

The problem seems to be in the line

.to = ActiveSheet.Range("m2")

The current 'sh' from the SourceWb was never activated, and its copy in the new workbook is no longer active because DestWb is already closed. Therefore the ActiveSheet should be the one in SourceWb which was active when you started the code.

I have gone through your code and made some comments. Not all of them are very useful but since I did the work please look for a benefit from it, if you like. :-). I also added the variable string "Addressee" and assigned the value from M2 of the 'sh' to it, using 'Addressee' then to fill the 'To' field.

Sub Split_To_Workbook_and_Email()
    ' 11 Nov 2017
    'Working in 2013/2016
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim myOutlook As Object
    Dim myMailItem As Object
    Dim Addressee As String
    Dim mySubject As String
    Dim myPath As String
    Dim strbody As String
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    Set otlApp = CreateObject("Outlook.Application")
    mySubject = "GDPR and your contacts - please read "
    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "f:\OnePlace\Strategy\GDPR\Primary Contact\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            Addressee = sh.Cells(2, "M").Value
            sh.Copy
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
            With Destwb
                'Determine the Excel version and file extension/format
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls"
                    FileFormatNum = -4143
                Else
                    'You use Excel 2007-2016
                    If Sourcewb.Name = .Name Then
                        ' === You are comparing the workbook name with the worksheet name !!!
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        FileExtStr = ".xlsx"
                        FileFormatNum = 51
                    End If
                End If
            End With
            ' Change all cells in the worksheet to values
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    
                    ' ambiguous coding:-
                    ' you can only select a cell in the ActiveSheet.
                    ' Therefore Destwb.Sheets(1) must be active.
                    .Cells(1).Select
                    ' the next command refers to the Activesheet
                    ' (observer the missing period in the lead!)
                    Cells.EntireColumn.AutoFit
                    ' if this code will only work on the ActiveSheet,
                    ' why call it Destwb.Sheets(1) ????
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it
            With Destwb
                .SaveAs FolderName _
                        & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
'                myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
                myPath = Destwb.FullName
'            With Destwb
                .Close False
            End With
            Set otlNewMail = otlApp.CreateiItem(olMailItem)
            With otlNewMail
                strbody = "As part of GDPR requirements we need to seek approval from our contacts to market to them our events and briefings. As a result, we are currently checking in with fee-earners to confirm their contact spread at their clients." & vbNewLine & _
                "I am contacting you regarding the contacts we hold for the attached company as based on our records you have billed the client in the last 2 years. At this stage, please can you collectively review the contacts in the attached file and respond to me by COB 22/11/17 with the following information:" & vbNewLine & _
                "1.  Validating current contacts - please enter a Y/N in the relevant column to determine whether we keep should keep these contacts on the system (i.e. if you still have contact with them / they are still at the entity concerned);" & vbNewLine & _
                "2.  Primary Contact - please enter one name here which will enable you to be informed of their preferences when they reply, be informed periodically of how we are marketing to them / their interests and importantly be the primary contact for the respective individual should someone in the firm wish to follow-up with you directly about that contact; and" & vbNewLine & _
                "3.  Additions - if there are any contacts you collectively have as a team not listed here please add them, with the respective columns completed, and we will add them to OnePlace and seek approvals for them on your behalf." & vbNewLine & _
                "If you have any questions please contact gdprcompliance@dacbeachcroft.com" & vbNewLine & vbNewLine & _
                "Kind regards " & vbNewLine
                
                .Subject = mySubject
                .Body = strbody
                .to = Addressee
                .SentOnBehalfOfName = """GDPRcompliance"" <GDPRcompliance@dacbeachcroft.com>"
                .Attachments.Add myPath
                .Display
            End With
            Set otlNewMail = Nothing
'        End With
        End If
GoToNextSheet:
' GoTo should be avoided. Better to replace it with an IF condition.
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
Discuss

Discussion

Thank you so much for your help. That has saved me lots of time as I could not work it out.
benfox (rep: 2) Nov 13, '17 at 8:03 am
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login