如何改进此VBA代码以添加复写副本

我正在努力改进我的代码，从我的前一篇文章，把一些复写抄送行代码。我想弄清楚的是，有些公司可能是我的抄送，这取决于我想发送的电子邮件类型

示例：我创建了两个我可能想发送电子邮件的抄送电子邮件列表

在公司名称前面，我将列表中的所有电子邮件连接到一个单元格中

我怎样才能把它输入到代码中，我可以选择公司的名称，并且该公司的所有电子邮件都会进入抄送列表

再次感谢你们给我的帮助

为了便于阅读，我将复制上一篇文章中的代码：

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

---

简短的答案可能是（尽管有点刺耳）：

将列D设置为cc列，该列将指向cc的C10的串联值 制作一个xCC=xRg.Cellsi，4 使xURL=mailto:&xEmail&？subject=&xSubj&&body=&xMsg&&cc=&xCC 我想指出的是，这很容易成为一个烂摊子，但它应该解决您的迫切需要

我建议采用以下解决方案，以获得更好的解决方案：

创建两个新列，假设J和K。J将保留公司名称，如XCCompany和K将保留公司对应的单个电子邮件地址。在您的示例中，您将为每个公司执行三次此操作，因为它们都有三个cc，并且最终有六个记录-三个公司的公司名称相同，但电子邮件地址不同。我们希望公司名称相同，以便我们可以搜索它们

此外，在D列中，您可以将公司名称存储到CC XCCompany，当您按下按钮时，宏将使用J和K中的信息查找与公司名称对应的电子邮件地址，将它们连接起来，并将它们作为CC。我发现了一个漂亮的UDF函数可以实现这一点

如果您想采用这种方法，可以在SendEmail函数下的模块中声明函数，而不是如上所述设置xCC，请按如下所示进行设置，确保保留对xURL的更改：

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

注：我只因性能问题而增加到K100和J100，您的列表可能会变长，如果是这样，您将需要相应调整

祝你好运

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

与：

3-最后，在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-将您的公司和电子邮件地址分配到不同的列，如下所示。通过这种方式，您可以根据需要设置任意多的公司

5-运行代码时，只需选择所需的公司单元格并单击“确定”

重要提示：您可以选择整列、所需列中的一系列单元格或所需列中的单个单元格。您的代码仍然有效，因为它只从您的选择中提取列号

编辑：如果您想重复选择密件抄送电子邮件的过程，在选择密件抄送后，您可以对不同的分配使用相同的功能，如下所示：

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

---

您可能希望在数据集中有一个字段，用于标识与您发送到的电子邮件关联的公司，该公司可能来自关联的电子邮件域（如果这是查找该公司的一致方法）。然后，当运行宏时，您可以根据您定义的公司字段查找CC列表，并使用类似于&CC=&xCCs的内容将其添加到xURL字符串中。我不知道URL需要的实际格式，这只是一个示例。非常好用，如果我想对CCO Carbon Copy Encurlt执行相同的过程，我是否必须创建一个新函数并重复您向我展示的相同步骤？你帮了我很多，非常感谢

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