如何提高這個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的性能問題，您的列表可以變長，如果是這樣，你會希望做相應的調整）

祝你好運！