Return email addresses from list in column

Question

I have open-sourced Excel VBA email code that takes all worksheets in a workbook, saves them to a file, then opens Outlook and adds the file as individual attachments to individual Outlook emails.

The email 'To:' address is not being entered properly.

Assume there are 10 worksheets in the workbook.
Sheet1 is the master worksheet with all of the individual records listed.
Sheets 2 - 10 contain the individual records from the main worksheet.

This code will incorrectly attach Sheet1 (The master) to Outlook with Sheet2's email address in the 'To' field. Sheet1 doesn't need to be emailed. The rest of the sheets are attached to Outlook with no 'To' address.

The first two rows are headers.
Column A contains names.
Column B contains email addresses.
The rest of the columns contain data.

Sub Split_To_Workbook_and_Email()

    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 otlApp As Object
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    'Prompt for Email Subject
    
    Set otlApp = CreateObject("Outlook.Application")
    mySubject = InputBox("Subject for Email")
    
    '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 = "C:\Temp\email_students\" & 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
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it
            Set otlNewMail = otlApp.CreateItem(olMailItem)
            With Destwb
                .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                  FileFormat:=FileFormatNum
            End With
            
            SDest = ""
            For iCounter = 3 To WorksheetFunction.CountA(Columns(2))
                If SDest = "" Then
                    SDest = Cells(iCounter, 2).Value
                'Else
                    'SDest = SDest & ";" & Cells(iCounter, 1).Value
                End If
            Next iCounter
                
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            With Destwb
                .Close False
            End With
            With otlNewMail
                .to = SDest
                .Subject = mySubject
                .Body = "*Enter email message here.*"
                .Attachments.Add myPath
                .Display
            End With
            
            Set otlNewMail = Nothing
        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

If sh.Visible = -1 And sh.Name <> "Sheet1" Then Use this so that Sheet1 is ignored and is not copied in the first place. — Siddharth Rout

brohjoe brohjoe · Accepted Answer · 2020-10-27T05:37:48

I fixed it. I changed the 'For Each' to look for the email address, got rid of the 'For iCounter' loop and added the value in the 'For Each' to the 'To:' field. Works perfectly now. Here is the final code:

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 otlApp As Object
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    'Prompt for Email Subject
    
    Set otlApp = CreateObject("Outlook.Application")
    mySubject = InputBox("Subject for Email")
    
    '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 = "C:\Temp\email_students\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        If sh.Range("B3").Value Like "?*@?*.?*" Then
            sh.Copy
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
            'Determine the Excel version and file extension/format
             FileExtStr = ".xlsx": FileFormatNum = 51
                   
         End If
           
            '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
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it
            Set otlNewMail = otlApp.CreateItem(olMailItem)
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
            End With
            
                              
            
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            With Destwb
                .Close False
            End With
            With otlNewMail
                .To = sh.Range("B3").Value 'email address location
                .Subject = mySubject
                .Body = "Enter body code here."
                .Attachments.Add myPath
                .Display
            End With
            
            Set otlNewMail = Nothing
        
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    End Sub

Return email addresses from list in column

1 Answers