Automatic Email not working properly

Damian37

Board Regular
Joined
Jun 9, 2014
Messages
227
I've written something to try and get automatic emails to be sent out based on whether there was information within a cell or not. I have two "asks": How would I code to review the data within a worksheet, and no matter how many records meet the criteria (POC information missing), only one email will be sent to recipients within two columns (19, 21) for that Region? The below image shows the missing POC name and email information needed for other automated reports:

1585942420993.png


Here's the code I've written. Instead of creating an email, when I click the send email button it directs me to the AllData worksheet. Stumped!!!

VBA Code:
Private Sub CommandButton2_Click()

Dim OutLookApp As Object

  Dim OutLookMailItem As Object
  Dim iCounter As Integer
  Dim MailDest As String
  Dim MailDest2 As String
 
  Set OutLookApp = CreateObject("Outlook.application")
  Set OutLookMailItem = OutLookApp.CreateItem(0)
 

  Worksheets("AllData").Activate

 
  For iCounter = 2 To WorksheetFunction.CountA(Columns(28))
    
     MailDest = ""
    
     If Len(Cells(iCounter, 28).Offset(0, -1)) > 0 Then
     If MailDest = "" And Cells(iCounter, 7).Offset(0, -1) = "Open" Then
            
     Set OutLookMailItem = OutLookApp.CreateItem(0)
     With OutLookMailItem
    
     MailDest = Cells(iCounter, 19).Value
     MailDest2 = Cells(iCounter, 21).Value
    
        .To = MailDest
        .CC = MailDest2
        .BCC = 
        .Subject = "Missing store POC"
        .HTMLBody = "To Whom It May Concern,<p>" _
            & "Please be advised the store POC information is currently missing for stores in your area. " _
            & "If available, please provide current store POC information in order" _
            & "for automatic emails to be sent to the correct store POC.<p>" _
            & "Please note: If the store POC field remains empty, all emails will be" _
            & "directed to ROMs and FMMs.<p>" _
            
    
    .Display
    '.Send
    End With
        .Attachments.Add ActiveWorksheet.FullName
        
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
            If Not objOutlookRecip.Resolve Then
            Exit Sub
        End If
    
      
        Next iCounter
    
  Set OutLookMailItem = Nothing
  Set OutLookApp = Nothing

End Sub

All help is greatly appreciated! Thank you so much!
D
 

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Watch MrExcel Video

Forum statistics

Threads
1,114,524
Messages
5,548,553
Members
410,848
Latest member
anuradhagrewal
Top