Email loop only sends first email from outlook.

Trying to send multiple individuals different emails based on cells within the worksheet. This basically grabs their organizational data and puts everything into an email so I can send it off and make sure everything is up to date. Problem is, it will shoot off the first email and that is it. It will still go through the whole list and say that it has emailed all contacts that have not been emailed in the last 90 days, but I do not see any emails sent from outlook.

Sub shootmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim X As Integer
    

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Stp = 1

vb = MsgBox("This will send emails to contacts that have not been emailed within 90 days. Do you wish to continue?", vbYesNo)
If vb = vbNo Then Exit Sub
    UserForm2.TextBox1.Text = "I am updating our command contact list and am requesting assistance in ensuring the following information is up to date or provide any missing data.  This is an automated email that gets sent around every 3 months and your assistance in helping maintain our 200+ command P.O.C. database is very helpful.  This information is maintained on a spreadsheet for specific members of our command.  This way, if there are any issues with your individuals that require assistance while here, one of our staff members can contact their counterpart in your command.  Please reply with corrections, fill in missing information, or to let me know that everything is up to date."
    UserForm2.TextBox3.Text = "Sir/Ma'am"
    UserForm2.Show
    Sheets("Update POC").Select
    Range("A1").Select
    If Stp = 1 Then Exit Sub
    
    'Get CO's Data

Do
    Sheets("Update POC").Select
    ActiveCell.Offset(1, 0).Select
If ActiveCell.Offset(0, 3).Value = "" Then GoTo A
If Date - ActiveCell.Offset(0, 3).Value > 90 Then
A:
        If ActiveCell.Offset(0, 1).Value = "" Then
        Else
        M2 = ActiveCell.Offset(0, 1).Value
        CMD = ActiveCell.Value
        Sheets("COs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            If ActiveCell.Value = "" Then
                MsgBox ("We were unable to find " & CMD & ".  Please make sure that it is in the command listing or removed from the Update POC list.")
                Sheets("Update POC").Select
                Exit Sub
            Else
            End If
            
            Loop Until ActiveCell.Value = CMD
            CO1 = ActiveCell.Offset(0, 2).Value
            CO2 = ActiveCell.Offset(0, 3).Value
            CO3 = ActiveCell.Offset(0, 4).Text
            ADX = ActiveCell.Offset(0, 6).Text
            
        Sheets("XOs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            XO1 = ActiveCell.Offset(0, 2).Value
            XO2 = ActiveCell.Offset(0, 3).Value
            XO3 = ActiveCell.Offset(0, 4).Text
            XO4 = ActiveCell.Offset(0, 5).Text
                
        Sheets("CMCs and COBs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            XO1 = ActiveCell.Offset(0, 2).Value
            XO2 = ActiveCell.Offset(0, 3).Value
            XO3 = ActiveCell.Offset(0, 4).Text
            XO4 = ActiveCell.Offset(0, 5).Text
                
        Sheets("JAGs").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            JG1 = ActiveCell.Offset(0, 2).Value
            JG2 = ActiveCell.Offset(0, 3).Value
            JG3 = ActiveCell.Offset(0, 4).Text
            JG4 = ActiveCell.Offset(0, 5).Text
        
        Sheets("ADMIN").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            AD1 = ActiveCell.Offset(0, 2).Value
            AD2 = ActiveCell.Offset(0, 3).Value
            AD3 = ActiveCell.Offset(0, 4).Text
            AD4 = ActiveCell.Offset(0, 5).Text
        
        Sheets("CCC").Select
            Range("A1").Select
            Do
            ActiveCell.Offset(1, 0).Select
            Loop Until ActiveCell.Value = CMD
            CC1 = ActiveCell.Offset(0, 2).Value
            CC2 = ActiveCell.Offset(0, 3).Value
            CC3 = ActiveCell.Offset(0, 4).Text
            CC4 = ActiveCell.Offset(0, 5).Text
        
    
        strbody = "Dear " & T2 & "," & vbNewLine & vbNewLine & _
                  "     " & MSG & vbNewLine & vbNewLine & vbNewLine & _
                  "Command: " & CMD & vbNewLine & vbNewLine & _
                  "Commanding Officer: " & CO1 & vbNewLine & _
                  "Email Address: " & CO2 & vbNewLine & _
                  "Phone Number:  " & CO3 & vbNewLine & vbNewLine & _
                  "Executive Officer: " & XO1 & vbNewLine & _
                  "Email Address: " & XO2 & vbNewLine & _
                  "Phone Number: " & XO3 & vbNewLine & _
                  "Cell Number:  " & XO4 & vbNewLine & vbNewLine & _
                  "CMC/COB: " & CM1 & vbNewLine & _
                  "Email Address: " & CM2 & vbNewLine & _
                  "Phone Number: " & CM3 & vbNewLine & _
                  "Cell Number:  " & CM4 & vbNewLine & vbNewLine & _
                  "JAG: " & JA1 & vbNewLine & _
                  "Email Address: " & JA2 & vbNewLine & _
                  "Phone Number:  " & JA3 & vbNewLine & vbNewLine & _
                  "Admin Officer: " & AD1 & vbNewLine & _
                  "Email Address: " & AD2 & vbNewLine & _
                  "Phone Number:  " & AD3 & vbNewLine & vbNewLine & _
                  "CCC: " & CC1 & vbNewLine & _
                  "Email Address: " & CC2 & vbNewLine & _
                  "Phone Number:  " & CC3 & vbNewLine & ADX & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
                  "Very Respectfully," & vbNewLine & vbNewLine & vbNewLine & _
                  "" & NM & vbNewLine & "Phone: (COM 360/DSN 744) " & PhN
                  
    
    
                  
    
        On Error Resume Next
        With OutMail
            .To = M2
            .CC = ""
            .BCC = ""
            .Subject = "TPU Contact list update"
            .Body = strbody
            .Display  'or use .Send
            Application.Wait Time + TimeSerial(0, 0, 5)
        End With
        On Error GoTo 0
        Sheets("Update POC").Select
        ActiveCell.Offset(0, 3).Value = Date
        End If
    
Else
End If


Loop Until ActiveCell.Value = ""


    Set OutMail = Nothing
    Set OutApp = Nothing



End Sub

Here's a dummy copy.

COMMAND CONTACT LIST DUMMY LOAD.xlsm

shootmail is the macro in question

Bumping to generate new looks... Still unresolved.

Janos

Is there a reason the main loop in the code is commented out?

Where can the relevant data, eg who to send email to, what to send etc, be found?

Yes there is, I forgot to change that when I loaded it. I figured since it was only doing it once, I was removing the loop and having to just run the macro over again with each click. The issue happens when the loop is there.

Surely you need some sort of loop if you want to send individual emails to different people?

The loop is there, I only removed it at the time because it would update the contacts page as being emailed for each email it was suppose to send. Problem one is that only the first email is going out. So if I kept the loop in there at the time, i would have to go through, see who the first email was sent to, and then erase every date after that. This is so I could send the email on occasion but if someone on the list was emailed within the past 90 days, it would skip them. That is the only reason why the loop was commented out.

I have uploaded a fixed copy of the spreadsheet. COMMAND CONTACT LIST DUMMY LOAD.xlsm

Hi Janos

There's a lot of "stuff" I'd change in the Code but try this for your "shootmail" macro....seems to work for me

Sub shootmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim X As Integer
    Dim rng As Range
    Dim cel As Range


    Set OutApp = CreateObject("Outlook.Application")
    '    Set OutMail = OutApp.CreateItem(0)
    Stp = 1

    vb = MsgBox("This will send emails to contacts that have not been emailed within 90 days. Do you wish to continue?", vbYesNo)
    If vb = vbNo Then Exit Sub
    UserForm2.TextBox1.Text = "I am updating the TPU Puget Sound command contact list and am requesting assistance in ensuring the following information is up to date or provide any missing data.  This is an automated email that gets sent around every 3 months and your assistance in helping maintain our 200+ command P.O.C. database is very helpful.  This information is maintained on a spreadsheet for specific members of our command.  This way, if there are any issues with transients that require assistance, one of our staff members can contact their counterpart in your command.  Please reply with corrections, fill in missing information, or to let me know that everything is up to date."
    UserForm2.TextBox3.Text = "Sir/Ma'am"
    UserForm2.Show
    Sheets("Update POC").Select
    Range("A1").Select
    If Stp = 1 Then Exit Sub

    'Get CO's Data

    '    Do
    Sheets("Update POC").Select
    'Range(("A2"), Range("A2").End(xlDown)).Select
    For Each cel In Range(("A2"), Range("A2").End(xlDown))
        ActiveCell.Offset(1, 0).Select
        If ActiveCell.Offset(0, 3).Value = "" Then GoTo A
        If Date - ActiveCell.Offset(0, 3).Value > 90 Then
A:
            If ActiveCell.Offset(0, 1).Value = "" Then
            Else
                M2 = ActiveCell.Offset(0, 1).Value
                CMD = ActiveCell.Value
                Sheets("COs").Select
                Range("A1").Select
                Do
                    ActiveCell.Offset(1, 0).Select
                    If ActiveCell.Value = "" Then
                        MsgBox ("We were unable to find " & CMD & ".  Please make sure that it is in the command listing or removed from the Update POC list.")
                        Sheets("Update POC").Select
                        Exit Sub
                    Else
                    End If

                Loop Until ActiveCell.Value = CMD
                CO1 = ActiveCell.Offset(0, 2).Value
                CO2 = ActiveCell.Offset(0, 3).Value
                CO3 = ActiveCell.Offset(0, 4).Text
                ADX = ActiveCell.Offset(0, 6).Text

                Sheets("XOs").Select
                Range("A1").Select
                Do
                    ActiveCell.Offset(1, 0).Select
                Loop Until ActiveCell.Value = CMD
                XO1 = ActiveCell.Offset(0, 2).Value
                XO2 = ActiveCell.Offset(0, 3).Value
                XO3 = ActiveCell.Offset(0, 4).Text
                XO4 = ActiveCell.Offset(0, 5).Text

                Sheets("CMCs and COBs").Select
                Range("A1").Select
                Do
                    ActiveCell.Offset(1, 0).Select
                Loop Until ActiveCell.Value = CMD
                XO1 = ActiveCell.Offset(0, 2).Value
                XO2 = ActiveCell.Offset(0, 3).Value
                XO3 = ActiveCell.Offset(0, 4).Text
                XO4 = ActiveCell.Offset(0, 5).Text

                Sheets("JAGs").Select
                Range("A1").Select
                Do
                    ActiveCell.Offset(1, 0).Select
                Loop Until ActiveCell.Value = CMD
                JG1 = ActiveCell.Offset(0, 2).Value
                JG2 = ActiveCell.Offset(0, 3).Value
                JG3 = ActiveCell.Offset(0, 4).Text
                JG4 = ActiveCell.Offset(0, 5).Text

                Sheets("ADMIN").Select
                Range("A1").Select
                Do
                    ActiveCell.Offset(1, 0).Select
                Loop Until ActiveCell.Value = CMD
                AD1 = ActiveCell.Offset(0, 2).Value
                AD2 = ActiveCell.Offset(0, 3).Value
                AD3 = ActiveCell.Offset(0, 4).Text
                AD4 = ActiveCell.Offset(0, 5).Text

                Sheets("CCC").Select
                Range("A1").Select
                Do
                    ActiveCell.Offset(1, 0).Select
                Loop Until ActiveCell.Value = CMD
                CC1 = ActiveCell.Offset(0, 2).Value
                CC2 = ActiveCell.Offset(0, 3).Value
                CC3 = ActiveCell.Offset(0, 4).Text
                CC4 = ActiveCell.Offset(0, 5).Text


                strbody = "Dear " & T2 & "," & vbNewLine & vbNewLine & _
                        "     " & MSG & vbNewLine & vbNewLine & vbNewLine & _
                        "Command: " & CMD & vbNewLine & vbNewLine & _
                        "Commanding Officer: " & CO1 & vbNewLine & _
                        "Email Address: " & CO2 & vbNewLine & _
                        "Phone Number:  " & CO3 & vbNewLine & vbNewLine & _
                        "Executive Officer: " & XO1 & vbNewLine & _
                        "Email Address: " & XO2 & vbNewLine & _
                        "Phone Number: " & XO3 & vbNewLine & _
                        "Cell Number:  " & XO4 & vbNewLine & vbNewLine & _
                        "CMC/COB: " & CM1 & vbNewLine & _
                        "Email Address: " & CM2 & vbNewLine & _
                        "Phone Number: " & CM3 & vbNewLine & _
                        "Cell Number:  " & CM4 & vbNewLine & vbNewLine & _
                        "JAG: " & JA1 & vbNewLine & _
                        "Email Address: " & JA2 & vbNewLine & _
                        "Phone Number:  " & JA3 & vbNewLine & vbNewLine & _
                        "Admin Officer: " & AD1 & vbNewLine & _
                        "Email Address: " & AD2 & vbNewLine & _
                        "Phone Number:  " & AD3 & vbNewLine & vbNewLine & _
                        "CCC: " & CC1 & vbNewLine & _
                        "Email Address: " & CC2 & vbNewLine & _
                        "Phone Number:  " & CC3 & vbNewLine & ADX & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
                        "Very Respectfully," & vbNewLine & vbNewLine & vbNewLine & _
                        "" & NM & vbNewLine & "Phone: (COM 360/DSN 744) " & PhN




                Set OutMail = OutApp.CreateItem(0)
                On Error Resume Next
                With OutMail
                    .To = M2
                    .CC = ""
                    .BCC = ""
                    .Subject = "TPU Contact list update"
                    .Body = strbody
                    .Display  'or use .Send
                    Application.Wait Time + TimeSerial(0, 0, 10)
                End With
                On Error GoTo 0
                Sheets("Update POC").Select
                ActiveCell.Offset(0, 3).Value = Date
            End If

        Else
        End If

    Next cel
    '    Loop Until ActiveCell.Value = ""


    Set OutMail = Nothing
    Set OutApp = Nothing



End Sub

Janos

I've looked at both the files you've attached but it's still unclear where, or even if, you have a list of the people you want to send emails to.

There is one sheet, 'Update POC', that has an email address but there are no dates.

The "Update POC" tab is where it gets the main Point of Contact (POC) for each of the commands. It sends an email to that POC asking for an update for the lists (CO, XO, CMC/COB, etc..). After a good email is sent to a command, it will go back to the "Update POC" page and insert todays date into the "Last Email" column.

The problem I have is that it will send out the email to the first one on the list that has a POC email and has not been emailed within the last 90 days (no date in block or date older than 90 days), then it will continue to run the program, inserting a "last email" date in the "Update POC" tab, but only that first email actually gets sent. This may be an issue on the Outlook side, but I wanted to see if there was any problems with my coding first.

So in summary, the flow should look like this.

1. Open Userform to ensure salutation, message body, and sender information are good
2. GO2 Update POC Tab
3. Find contact that hasn't been emailed last 90 days (If no contacts, end macro)
4. Gather information from CO, XO, CMC/COB, JAG, Admin, & CCC tabs for the command
5. Set up email to send by including all information gathered
   
6. Send email
7. Put date on "Update POC" for email
8. Wait 5 seconds (to allow any computer locking during processing since government computers are oh so slow)
9. GO2 Step 2 and repeat.

If you want to give it a test run or two.. You can put your email in the "Update POC" tab for the three dummy commands or you can throw my email there (Ford68Pony@yahoo.com) and give it some test runs.

If it's working for you and not me then this is probably an outlook and/or a government computer setup issue. So I will just have to revise my code and have it work it's magic one email at a time per click. Thanks for your help in this and I'll take a look at the code and see how it works for me. I'm pretty much a self taught macro with no other program language skills :-).

Hi Janos

Did you try the revised Code?

No, not yet. Boss' priorities changed so new tasking at hand. When I get that accomplished I'll see about moving through this and seeing how it goes.

Hi Janos

Let me know...