Clean up Code

[JRR1229]

I wrote this part of a code to cycle through two columns of emails and company names and add them to a BCC line of an email. The first part cycles through the emails that the person chooses by checking check boxes next to the email. the send part cycles through the company names of the emails and checks to see if there are any companies that require to have another email added to the BCC line in addition to the one with the check box. I want to know if there is a way of cleaning this up to do the same thing. I have tried the Select Case and ElseIf Commands with no success.

' Strings to contain the email addresses
     Dim sendBCC As String

' The cell containing the email address (loop variable)
     Dim emailCell As Range
     With Worksheets(M)

' Cycle through email addresses, from C5 to one before next blank cell in column
     For Each emailCell In .Range("C4", .Range("C4").End(xlDown))
     
' Check each TRUE/FALSE column in same row, add email addresses accordingly
     If .Cells(emailCell.Row, "N").Text = "TRUE" Then
          sendBCC = sendBCC & "; " & emailCell.Text
          
     End If

     Next emailCell
     
' Strings to contain the company
     Dim companyBCC As String

' The cell containing the company(loop variable)
     Dim companyCell As Range

' Cycle through email addresses, from D5 to one before next blank cell in column
     For Each companyCell In .Range("D4", .Range("D4").End(xlDown))
     
' Check each TRUE/FALSE column in same row, add company accordingly
     If .Cells(companyCell.Row, "N").Text = "TRUE" Then
          companyBCC = companyBCC & ", " & companyCell.Text
     
     End If
     
     Next companyCell
     
     If InStr(1, companyBCC, "Their Company") Then
          sendBCC = sendBCC & "; " & "theircompany@whatever.com"
     End If
     
     If InStr(1, companyBCC, "Any Company") Then
          sendBCC = sendBCC & "; " & "anycompany@whatever.com"
     End If
     
     If InStr(1, companyBCC, "This Company") Then
          sendBCC = sendBCC & "; " & "thiscompany@whatever.com"
     End If
     
     If InStr(1, companyBCC, "My Company") Then
          sendBCC = sendBCC & "; " & "mycompany@whatever.com"
     End If
     
     If InStr(1, companyBCC, "LLC") Then
          sendBCC = sendBCC & "; " & "llc@whatever.com"
     End If
     
     If InStr(1, companyBCC, "Said Company") Then
          sendBCC = sendBCC & "; " & "saidcompany@whatever.com"
     End If
     
     If InStr(1, companyBCC, "Company") Then
          sendBCC = sendBCC & "; " & "company@whatever.com"
     End If
     
     If InStr(1, companyBCC, "Company Name") Then
          sendBCC = sendBCC & "; " & "companyname@whatever.com"
     End If
     
     If InStr(1, companyBCC, "Example Company") Then
          sendBCC = sendBCC & "; " & "examplecompany@whatever.com"
     End If
     
     End With

     On Error Resume Next

 

[Zot]

What about this?

' Strings to contain the email addresses
Dim sendBCC         As String

' The cell containing the email address (loop variable)
Dim emailCell       As Range
With Worksheets(M)
    
    ' Cycle through email addresses, from C5 to one before next blank cell in column
    For Each emailCell In .Range("C4", .Range("C4").End(xlDown))
        ' Check each TRUE/FALSE column in same row, add email addresses accordingly
        If .Cells(emailCell.Row, "N").Text = "TRUE" Then
            sendBCC = sendBCC & "; " & emailCell.Text
        End If
    Next emailCell
    
    ' Strings to contain the company
    Dim companyBCC  As String
    
    ' The cell containing the company(loop variable)
    Dim companyCell As Range
    
    ' Cycle through email addresses, from D5 to one before next blank cell in column
    For Each companyCell In .Range("D4", .Range("D4").End(xlDown))
        ' Check each TRUE/FALSE column in same row, add company accordingly
        If .Cells(companyCell.Row, "N").Text = "TRUE" Then
            companyBCC = companyBCC & ", " & companyCell.Text
        End If
    Next companyCell
    
    ' Create a collection of companies' name
    Dim collCompany As New Collection
    
    collCompany.Add "Their Company"
    collCompany.Add "Any Company"
    collCompany.Add "This Company"
    collCompany.Add "My Company"
    collCompany.Add "LLC"
    collCompany.Add "said Company"
    collCompany.Add "Company"
    collCompany.Add "Company Name"
    collCompany.Add "Example Company"
    
    Dim coName As Variant
    
    For Each coName In collCompany
        If InStr(companyBCC, coName) Then
            sendBCC = sendBCC & "; " & coName & "@whatever.com"
        End If
    Next
        
End With

 

[JRR1229]

I think by @whatever.com was a bad thing to put after everyone of the companies emails. Every email recipient will have a different domain name as well

 

[Zot]

I think by @whatever.com was a bad thing to put after everyone of the companies emails. Every email recipient will have a different domain name as well

I looked at your code and it is all @WHATEVER. I thought all same domain

If you want each company name paired with own domain name, then probably it is easier to use Dictionary where it is easier to get key and item pair as company and domain perhaps.

Excel VBA Dictionary - A Complete Guide - Excel Macro Mastery

This post contains everything you need to know about using the VBA Dictionary. There are tons of code examples including a real world application.

excelmacromastery.com