如何提高这个VBA代码添加碳复制到它

Question

我想改善我的代码我从以前的帖子Predetermine the cells with the data to send emails把一些碳复制（CC）的行代码。我想弄清楚的是，有些公司可能是我的CC，这取决于我想发送的电子邮件类型。

例如：我创建了2个CC电子邮件列表，我可能想发送电子邮件。

在公司名称前面我串连所有列表中的邮件只有一个细胞。

我怎样才能把这个代码放入我可以选择公司名称的公司名称以及该公司的所有电子邮件都转到CC列表中？

再次感谢你们帮助你们给我的所有帮助。

我将代码从以前的帖子复制只是为了更容易阅读：

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，在你的代码之后：

If xRg Is Nothing Then Exit Sub 

插入：

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，然后更换：

xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg 

有：

xURL = "mailto:" & xEmail & "?subject=" & xSubj & xCC & "&body=" & xMsg 

3，最后添加以下功能的子之后：如下图所示

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分配你的公司的电子邮件地址，以不同的列一起。你可以用这种方式设置尽可能多的公司。

5 - 当你运行你的代码，请选择您想要的公司细胞，然后点击确定。

重要说明：您可以选择整列，即所需列中的一系列单元格或所需列中的单个单元格。您的代码仍然可以工作，因为它仅从您的选择中提取列号。

编辑：如果你想重复这一过程选择BCC电子邮件，选择CCS之后，你可以使用不同的分配是这样相同的功能：

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 

和修改你的xURL这样

xURL = "mailto:" & xEmail & "?subject=" & xSubj & xCC & xBCC & "&body=" & xMsg 

Answer 2

简短的回答（尽管有些janky）可能是：

• 使列d你“抄送”一栏，这将指向毫升的（C10）的级联值
• 做出xCC = xRg.Cells(i, 4)
• 使xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg & "&cc=" & xCC

我想指出，这很容易变成一团糟，但它应该解决您的直接需求。

我建议的解决方案下面一个更好的方法：

创建2个新列（假设J和K）。 J将持有公司名称（如XCCompany），K将持有与该公司相对应的单个电子邮件地址。在你的例子中，你会为每个公司做三次这样的事情（因为他们都有三个cc，最后有六个记录） - 三个公司名称相同，但电子邮件地址不同。我们希望公司名称相同，以便我们可以搜索它们。

此外，在列d您可以将公司的名称保存到CC（XCCompany），当你按下按钮宏将查找对应于公司名称（使用J和K的信息）的电子邮件地址，连接它们，并将它们作为cc的。我发现了一个漂亮的小UDF函数，可以做到这一点http://www.excelfox.com/forum/showthread.php/345-LookUp-Value-and-Concatenate-All-Found-Results。

如果你想要采取这种方法，在一个模块中声明该函数（也许在你的SendEmail功能），而不是设置XCC如上所示，设置如下所示（请务必保留更改到xURL ）：

xCC = LookUpConcat(xRg.Cells(i, 4), Range("J2:J100"), Range("K2:K100"), ";") 

（请注意，我只走到K100和J100的性能问题，您的列表可以变长，如果是这样，你会希望做相应的调整）

祝你好运！