Einbetten von CC und BCC in den VBA-Makrocode beim Senden von Zeilen an eindeutige Person

Question

Ich habe ein Makro, das eine Zeile oder Zeilen an jede Person in einem Bereich mailen würde. Ich möchte nur wissen, wie CC und BCC, die in jeder E-Mail-Adresse identisch sind hinzuzufügen. Ich bin amature Excel VBA. Bitte helfen Sie.

hier ist der Code

Sub Send_Row_Or_Rows_1() 

Dim OutApp As Object 
Dim OutMail As Object 
Dim rng As Range 
Dim Ash As Worksheet 
Dim Cws As Worksheet 
Dim Rcount As Long 
Dim Rnum As Long 
Dim FilterRange As Range 
Dim FieldNum As Integer 
Dim mailAddress As String 
Dim StrBody As String 

On Error GoTo cleanup 
Set OutApp = CreateObject("Outlook.Application") 

With Application 
    .EnableEvents = False 
    .ScreenUpdating = False 
End With 


Set Ash = ActiveSheet 

'Set filter range and filter column (Column with names) 
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count) 
FieldNum = 1 'Filter column = A because the filter range start in A 

'Add a worksheet for the unique list and copy the unique list in A1 
Set Cws = Worksheets.Add 
FilterRange.Columns(FieldNum).AdvancedFilter _ 
     Action:=xlFilterCopy, _ 
     CopyToRange:=Cws.Range("A1"), _ 
     CriteriaRange:="", Unique:=True 

'Count of the unique values + the header cell 
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1)) 

'If there are unique values start the loop 
If Rcount >= 2 Then 
    For Rnum = 2 To Rcount 

     'Filter the FilterRange on the FieldNum column 
     FilterRange.AutoFilter Field:=FieldNum, _ 
           Criteria1:=Cws.Cells(Rnum, 1).Value 

     'Look for the mail address in the MailInfo worksheet 
     mailAddress = "" 
     On Error Resume Next 
     mailAddress = Application.WorksheetFunction. _ 
         VLookup(Cws.Cells(Rnum, 1).Value, _ 
          Worksheets("Mailinfo").Range("A1:B" & _ 
          Worksheets("Mailinfo").Rows.Count), 2, False) 
     On Error GoTo 0 

     If mailAddress <> "" Then 
      With Ash.AutoFilter.Range 
       On Error Resume Next 
       Set rng = .SpecialCells(xlCellTypeVisible) 
       On Error GoTo 0 
      End With 

      Set OutMail = OutApp.CreateItem(0) 

      On Error Resume Next 

      With OutMail 
       .to = mailAddress 
       .Subject = "Test mail" 
       .HTMLBody = StrBody & RangetoHTML(rng) 
       .Display 'Or use Send 

       StrBody = Sheets("Sheet2").Range("A1").Value & "<br>" & "<br>" & _ 
      Sheets("Sheet2").Range("A2").Value & "<br>" & "<br>" & _ 
      Sheets("Sheet2").Range("A3").Value & "<br><br><br>" 

      End With 
      On Error GoTo 0 

      Set OutMail = Nothing 
     End If 

     'Close AutoFilter 
     Ash.AutoFilterMode = False 

    Next Rnum 
End If 
cleanup: 
Set OutApp = Nothing 
Application.DisplayAlerts = False 
Cws.Delete 
Application.DisplayAlerts = True 

With Application 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 
End Sub 

Answer 1

Sollte

  With OutMail 
       .to = mailAddress 
       .cc = "email address" 
       .Bcc ="email address" 

sein, wenn Sie mehr als eine E-Mail hinzufügen möchten dann

.cc = "email address; email address"

Answer 2

rate ich eine separate Unter mit - Routine zum Senden der E-Mail. Verwenden Sie die vorhandene Subroutine zum Klassifizieren der Daten und rufen Sie die folgende Subroutine auf, wenn Sie die E-Mail senden möchten. Dies wird Ihr Problem des Hinzufügens und Auflösens der bcc- und cc-Mail-Adressen lösen und zusätzlich eine ausgezeichnete Speicherverwaltung mit der Outlook-Instanz ermöglichen.

Bitte benutzen Sie den folgenden Code:

Sub SendEmail(ByVal str_To_EmailAddress As String, ByVal strSubject As String, ByVal strHTMLBody As String) 
Dim OutApp As Object 
Dim oMsg As Object 
Dim objRecip As Object 

Dim str_CC_EmailAddress As String 
Dim str_BCC_EmailAddress As String 

Set OutApp = CreateObject("Outlook.Application") 
Set oMsg = OutApp.ActiveInspector.CurrentItem 

str_CC_EmailAddress = "ABC@example.com" 
str_BCC_EmailAddress = "XYZ@example.com" 

With oMsg 
    'Add to Email Address 
    Set objRecip = oMsg.Recipients.Add(strToEmailAddress) 
    objRecip.Type = olTo 
    objRecip.Resolve 

    'Add CC Email Address 
    Set objRecip = oMsg.Recipients.Add(str_CC_EmailAddress) 
    objRecip.Type = olCC 
    objRecip.Resolve 

    'Add BCC Email Address 
    Set objRecip = oMsg.Recipients.Add(str_BCC_EmailAddress) 
    objRecip.Type = olBCC 
    objRecip.Resolve 

    'Add Subject 
    .Subject = strSubject 

    'Add Body 
    .BodyFormat = olFormatHTML 

    'Display or Send 
    .Display '.Send 
End With 

Set oMsg = Nothing 

End Sub 

Bitte die Saiten der E-Mail-Adressen durch ein Semikolon getrennt konstruieren (;).