E-mail addresses in Range only picking up first e-mail address

[Kellis]

Hi all,

I have VBA that will send an e-mail and attachment to all e-mail addresses in a range, it worked well. However, I must have inadvertently changed something and it now only sends the e-mail to the first email address in the range and does not loop through the range adding all the e-mail addresses. I cannot work it out at all.
Please can someone help me?

The range the addresses are in are Y14:Z24

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Tom As Date
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook
    

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
    
  'Delete all Objects except Comments
    On Error Resume Next
    ActiveSheet.DrawingObjects.Visible = True
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    
     '~~>To Hide Rows 3 to 4
    Rows("3:4").EntireRow.Hidden = True
    
  
          
    '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
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    '    'Change all cells in the worksheet to values if you want
     With Destwb.Sheets(1).UsedRange
    .Cells.Copy
    .Cells.PasteSpecial xlPasteValues
    .Cells(1).Select
    End With
    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm")

    Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo cleanup
    For Each cell In Columns("Y").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then

    Set OutMail = OutApp.CreateItem(0)
    
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
         End With
        
            With OutMail
                .To = cell.Value

            .CC = ""
            .BCC = ""
            .Subject = "Reviw Form"
            .Body = "Hello," & vbNewLine & vbNewLine & "Please see attached form for review and comment." & vbNewLine & vbNewLine _
            & "Please review by the Date Required and return with comments." _
            & vbNewLine & vbNewLine & "Regards," & vbNewLine & vbNewLine & "Manager."
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
            ActiveWorkbook.Close
        End With
        
        
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell
    
    
  

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub

 

[Chihiro]

Without looking at your workbook, bit hard to say what exactly is causing issue.
I'd recommend uploading sample file, that replicates your error, with desensitized info. But retaining all the data structures and set up.

Also, I'd recommend stepping through code and identify what each of the variables hold when code terminates/exits.
Use Locals Window, Watch Window etc, along with F8.

One thing you can check... You mention that addresses are in Y14:Z24 range.

But code only checks for Y.

For Each cell In Columns("Y").Cells.SpecialCells(xlCellTypeConstants)