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

 

[Jyggalag]

Hi Rory,

Had to edit this one out. Your method works! Thank you so much!

And happy to hear that I was right about that one part :D