Excel 2010 VBA looping issue when sending emails

[XfortunaX]

The first email will send and the macro will continue to loop through (from watching the locals window it looks like everything is accurate) but nothing is sent after the first email. Here is the code:

Sub Mail_AMEX_Outlook()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim EmailBody As String
Dim NumNewAMEX As Integer
Dim X As Integer

Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(Outmailitem)

X = 2

NumNewAMEX = Application.CountA(Range("A:A"))

Do While X <= NumNewAMEX

EmployeeName = Cells(X, 1).Value
EmployeeEmail = Cells(X, 3).Value
FilePath = Cells(X, 4).Value
EmailBody = Cells(X, 5).Value
EmailBody = Replace(EmailBody, "Employeename", EmployeeName)
EmailBody = Replace(EmailBody, "Employeename", AMEXDate)

On Error Resume Next
With olMail
.To = EmployeeEmail
.CC = ""
.BCC = ""
.Subject = "AMEX Reconciliation: 06.14.2015"
.BodyFormat = olFormatHTML
.HTMLBody = EmailBody
.Attachments.Add FilePath
.SendUsingAccount = olApp.Session.Accounts.Item(2)
.Send 'or use .Display

End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

X = X + 1
Loop

End Sub

Any help on this issue would be greatly appreciated.

Thank you,

Tuna