How to improve this VBA code to add Carbon Copy into it - vba

Question

I am trying to improve my code my from previous post Predetermine the cells with the data to send emails to put some Carbon Copy (CC) on the line code. What I am trying to figure out is that there are some companies that might be my CC's, that depends of the type of email I want to send.
Example: I created 2 lists of CC emails That I might wanna send emails.
In front of the company's name I Concatenate all the emails from the list to only one cell.
How can I put this into the code that I can choose the name of the company and all the emails from that company goes to the CC list?
Thank you one more time for all the helping you guys are giving me.
I am going to copy the code from the previous post just to be easier to read:
Sub SendEMail()
'update by Extendoffice 20160506
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Range("A2:C6")
If xRg Is Nothing Then Exit Sub
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 2)
' Message subject
xSubj = "Your Registration Code"
' Compose the message
xMsg = ""
xMsg = xMsg & "Dear " & xRg.Cells(i, 1) & "," & vbCrLf & vbCrLf
xMsg = xMsg & " This is your Registration Code "
xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & " please try it, and glad to get your feedback! " & vbCrLf
xMsg = xMsg & "Skyyang"
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.DisplayKeys "%s"
Next
End Sub

Answer 1

1-In your code after:
If xRg Is Nothing Then Exit Sub
insert:
Dim CCCompany As Integer
Dim ccstr As String
ccstr = FindMyCompany()
If ccstr = vbNullString Then
CCCompany = MsgBox("No cc email selected. Are you sure you want to proceed?", vbYesNo + vbQuestion, "To be or not to be")
If CCCompany = vbYes Then
xCC = ""
Else
Exit Sub
End If
Else
xCC = "&cc=" & ccstr
End If
2-Then replace:
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
with:
xURL = "mailto:" & xEmail & "?subject=" & xSubj & xCC & "&body=" & xMsg
3-Finally add below function after your sub:
Function FindMyCompany() As String
Dim rng As Range
Dim i As Long
Dim xCC As String
Application.DisplayAlerts = False
Set rng = Application.InputBox("Select desired Company column or any cell in that column", _
"Get Company Column", Type:=8)
Application.DisplayAlerts = True
i = 1
Do Until IsEmpty(Cells(i, rng.Column))
Set crng = Cells(i, rng.Column)
If InStr(crng.Value, "#") Then
xCC = xCC & crng.Value & ";"
End If
i = i + 1
Loop
FindMyCompany = Left(xCC, Len(xCC) - 1)
End Function
4-Allocate your Companies along with email addresses to different columns as shown below. You can set as many company as you need this way.
5-When you run your code, simply select your desired company cell and click ok.
Important note: You can select the whole column, a range of cells from desired column or a single cell in the desired column. Your code will still work since it extracts only column number from your selection.
Edit: If you want to repeat this process for selecting bcc emails, right after selecting ccs, you can use the same function with different assignment like this:
Dim CCCompany As Integer
Dim ccstr As String
Dim bccstr As String
ccstr = FindMyCompany()
bccstr = FindMyCompany()
If ccstr = vbNullString Then
CCCompany = MsgBox("No cc email selected. Are you sure you want to proceed?", vbYesNo + vbQuestion, "To be or not to be")
If CCCompany = vbYes Then
xCC = ""
Else
Exit Sub
End If
Else
xCC = "&cc=" & ccstr
End If
If bccstr = vbNullString Then
BCCCompany = MsgBox("No cc email selected. Are you sure you want to proceed?", vbYesNo + vbQuestion, "To be or not to be")
If BCCCompany = vbYes Then
xBCC = ""
Else
Exit Sub
End If
Else
xBCC = "&bcc=" & bccstr
End If
and amend your xURL like this
xURL = "mailto:" & xEmail & "?subject=" & xSubj & xCC & xBCC & "&body=" & xMsg

Answer 2

The short answer (albeit somewhat janky) might be to:
Make Column D you "cc" column which will point to the concatenated value of the cc's (C10)
make an xCC = xRg.Cells(i, 4)
make xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg & "&cc=" & xCC
I do want to point out that this is prone to becoming a mess, but it should solve your immediate need.
I would recommend the solution below for a better approach:
Create 2 new columns (let's say J and K). J will hold the Name of the companies, (like XCCompany) and K will hold a single email address corresponding to the company. In your example you would do this three times for each company (since they both have three cc's and end up with six records) -- the company name will be the same for three but the email addresses will be different. We want the company names to be the same so that we can search on them.
ADDITIONALLY, in column D you can store the name of the company to CC (XCCompany) and when you press the button the macro will lookup email addresses that correspond to the company name (using the info in J and K), concatenate them, and put them as cc's. I found a nifty little UDF function that does this http://www.excelfox.com/forum/showthread.php/345-LookUp-Value-and-Concatenate-All-Found-Results.
If you wanted to take this approach, declare the function in a module (maybe under your SendEmail function) and instead of setting xCC as indicated above, set it as indicated below (make sure to keep the changes to xURL):
xCC = LookUpConcat(xRg.Cells(i, 4), Range("J2:J100"), Range("K2:K100"), ";")
(Note I only went up to K100 and J100 for performance issues, your list could grow longer and if so, you would want to adjust accordingly.)
Good Luck!