Email macro

[Jyggalag]

Hi all,

I currently have this code:

Option Explicit

Private Const FilePath As String = "\\COMPANY.MTJG.COMPANY.NET\userdata\t6853532895\home\Documents\TEST folder\"
Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim col As New Collection, itm As Variant
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
   
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
    
    '~~> Looping from rows 2 to 11 to create a unique collection of company names
    For i = 2 To 11
        On Error Resume Next
        col.Add ws.Cells(i, 2).Value2, CStr(ws.Cells(i, 2).Value2)
        On Error GoTo 0
    Next i
    
    '~~> Looping through the company names
    For Each itm In col
        '~~> Resetting the to and bcc address and the subject
        ToAddress = "": BCCAddress = "": EmailSubject = ""
        
    '~~> Constructing your addresses and subject
        For i = 2 To 11
            '~~> Check if the company name matches
            If ws.Cells(i, 2).Value2 = itm Then
                ToAddress = ToAddress & ";" & _
                            ws.Cells(i, 3).Value2 & ";" & ws.Cells(i, 4).Value2 & ";" & ws.Cells(i, 5).Value2
                            
                BCCAddress = BCCAddress & ";" & _
                             ws.Cells(i, 6).Value2
                             
                If EmailSubject = "" Then EmailSubject = ws.Cells(i, 1).Value2
            End If
        Next i
        
          '~~> Removing the first ";"
        ToAddress = Mid(ToAddress, 2)
        BCCAddress = Mid(BCCAddress, 2)
   
        '~~> This creates a new email (so we can send out multiple emails)
        Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = ToAddress
.BCC = BCCAddress
.Subject = EmailSubject
.HTMLBody = Range("B14") & "<BR>" & "<BR>" & _
"<b><u>" & Range("B15") & "</b></u>" & " " & _
Range("B16") & "<BR>" & "<BR>" & _
Range("B17") & "<BR>" & _
Range("B18")
.Attachments.Add FilePath & ws.Cells(2, 7).Value2

.Display

End With
Next itm

End Sub

My excel sheet looks like this:

What I want is to basically get rid of cell B1-B11. I do not need this section anymore and I do not want my VBA code to be dependent it. However, I am unsure how I can remove this from my code, because whenever I do the code simply wont run.

I did not create the code, I got it from a very nice person on this forum a while back. I understand most of it, but have been unable to edit this part away successfully.

Can somebody please help me?

I just want the email to take cell values A2-A11 as the subject for the emails and then email them to the contacts in the adjacent cells for column C-E and BCC for column F. It should then display about 10 emails with the same file attached.

Hope this makes sense. I would REALLY appreciate some assistance here!

Thank you all!

Kind regards,
Jyggalag

 

[RoryA]

Your current code is pretty much entirely based on sending one email to each company. What do you want it to actually do now?

 

[Jyggalag]

Your current code is pretty much entirely based on sending one email to each company. What do you want it to actually do now?

Hi Rory

I want it to do exactly that. But I want to the top of column B entirely from cell B1-B11. However, if I remove the values in these cells the code collapses and I cannot run it for some reason.

Also (and probably related to the above issue) when I try to send out the emails, it sends out duplicate emails to company 1 because a part of the code creates a company 1 value in cell B2 and B3

 

[RoryA]

I have no idea what you mean. None of that code populates B2 or B3. How is the code supposed to send one email per company if you remove the company info?

 

[Jyggalag]

I have no idea what you mean. None of that code populates B2 or B3. How is the code supposed to send one email per company if you remove the company info?

Hi Rory,

Sorry if I sounded unintelligible.

The code is supposed to look at the subject from cell A2-A11

Then the code should send an email with subject A2 to the emails listed in C2, D2, E2 and with F2 in BCC and then attach the file as well.

The body of the email should be cell B13-B18.

After this, the macro should display the email and then do the exact same thing for subject A3 with the emails in C3, D3, E3 and F3 in BCC and attach the same file.

After this, it should continue doing it for A4, A5 etc.

Does this make more sense? Please let me know if you want me to elaborate further.

The issue is, that currently the code is doing some stuff where it generates company names in column B and has the email somehow depend on this. I do not want this and I want to fix it (it is from an older file that I no longer need). I essentially just want my code to do what I mentioned above

Kind regards,
Jyggalag

 

[RoryA]

Try something like this:

Private Const FilePath As String = "\\COMPANY.MTJG.COMPANY.NET\userdata\t6853532895\home\Documents\TEST folder\"
Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
   
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
        
    Dim BodyText As String
    BodyText = ws.Range("B14") & "<BR>" & "<BR>" & _
         "<b><u>" & ws.Range("B15") & "</b></u>" & " " & _
         ws.Range("B16") & "<BR>" & "<BR>" & _
         ws.Range("B17") & "<BR>" & _
         ws.Range("B18")
         
   Dim AttachmentName As String
   AttachmentName = FilePath & ws.Cells(2, 7).Value2
         
    For i = 2 To 11
      '~~> Constructing your addresses and subject
      
      ToAddress = ws.Cells(i, 3).Value2 & ";" & ws.Cells(i, 4).Value2 & ";" & ws.Cells(i, 5).Value2
                  
      BCCAddress = ws.Cells(i, 6).Value2
                   
      EmailSubject = ws.Cells(i, 1).Value2
      '~~> This creates a new email (so we can send out multiple emails)
      Set OutMail = OutApp.CreateItem(0)

      With OutMail
         .To = ToAddress
         .BCC = BCCAddress
         .Subject = EmailSubject
         .HTMLBody = BodyText
         .Attachments.Add AttachmentName
         
         .Display
      
      End With
   Next i

End Sub

 

[Jyggalag]

Try something like this:

Private Const FilePath As String = "\\COMPANY.MTJG.COMPANY.NET\userdata\t6853532895\home\Documents\TEST folder\"
Sub send_email_complete()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Long
    Dim ws As Worksheet
    Dim ToAddress As String, BCCAddress As String, EmailSubject As String
  
    '~~> Change this to the relevant worksheet
    '~~> that has the emails (right now Sheet1 has it)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")
       
    Dim BodyText As String
    BodyText = ws.Range("B14") & "<BR>" & "<BR>" & _
         "<b><u>" & ws.Range("B15") & "</b></u>" & " " & _
         ws.Range("B16") & "<BR>" & "<BR>" & _
         ws.Range("B17") & "<BR>" & _
         ws.Range("B18")
        
   Dim AttachmentName As String
   AttachmentName = FilePath & ws.Cells(2, 7).Value2
        
    For i = 2 To 11
      '~~> Constructing your addresses and subject
     
      ToAddress = ws.Cells(i, 3).Value2 & ";" & ws.Cells(i, 4).Value2 & ";" & ws.Cells(i, 5).Value2
                 
      BCCAddress = ws.Cells(i, 6).Value2
                  
      EmailSubject = ws.Cells(i, 1).Value2
      '~~> This creates a new email (so we can send out multiple emails)
      Set OutMail = OutApp.CreateItem(0)

      With OutMail
         .To = ToAddress
         .BCC = BCCAddress
         .Subject = EmailSubject
         .HTMLBody = BodyText
         .Attachments.Add AttachmentName
        
         .Display
     
      End With
   Next i

End Sub

Rory you are an absolute genius


Thank you SO much!

It works to perfection

If you don't mind me asking (and please ignore this if you do, as I do not want to take too much of your time, you have already helped me so much with this!), I have two small questions:

1) If I wipe out the contacts from row 11 and remove the subject (which is "TEST 10" here), and I click the macro email, it generates 9 emails and then 1 untitled email with no information. Is there any way to make it so it will not generate the last email when I click the macro without going into VBA and editing the range every time?
2) I currently set up my body message in multiple cells, henceforth I had to make the code like this:

. I would naturally prefer to do it all in one cell, but this seems to be impossible for two reasons: 1) I cannot put a specific part of the text in underline/bold then, and 2) I cannot make a line break (vnewline or<BR> in vba) then, even if I type the text in such a format in Excel.

Thank you so much once again!

 

[RoryA]

You can change the loop to:

For i = 2 To ws.cells(ws.rows.count, "A").end(xlup).row

assuming there is nothing in column A below your actual data.

#2 isn't a question.

 

[Jyggalag]

You can change the loop to:

For i = 2 To ws.cells(ws.rows.count, "A").end(xlup).row

assuming there is nothing in column A below your actual data.

#2 isn't a question.

Amazing, thank you!! I will look into this immediately.

Regarding 2) my question was essentially if you had an easier solution than the one I implemented, for example somehow to just type the text in a cell and refer to this (has seemed impossible thus far for me)

Otherwise, truly no issue!

 

[RoryA]

Your current method is the simplest, to my mind.