title: Sending multiple emails using data from excel cells using VBA
body: <p>I've got a spreadsheet of clients with their client name, email address, contact and admin listed.
  I want to be able to send an individual email to each client using the data from the rows that the client is listed.</p>
  
  <p>I've got some VBA that I've written (parts obtained from other people) but it's trying to add all the email addresses to the to field and every other field is pulling all the data instead of the relevant row.</p>
  
  <p>I'm fairly new to this VBA stuff and would greatly appreciate some help.</p>
  
  <p>How can I make it draft individual emails per client with the information from just the row the client is listed.</p>
  
  <p>Example data:</p>
  
  <p>Column B has client names from row 3 down</p>
  
  <p>Column C has email addresses from row 3 down</p>
  
  <p>Column E has contact name from row 3 down</p>
  
  <p>Column G has admin name from row 3 down</p>
  
  <p>Here's the VBA:</p>
  
  <pre><code>    Option Explicit
  
  Sub AlexsEmailSender()
      Dim OutApp As Object
      Dim OutMail As Object
      Dim lngLastRow  As Long
      Dim rngMyCell   As Range
      Dim objEmailTo  As Object
      Dim strEmailTo  As String
      Dim objCCTo     As Object
      Dim strCCTo     As String
      Dim objContact As Object
      Dim strContact As String
      Dim objAdmin As Object
      Dim strAdmin As String
      Dim strbody     As String
      Dim objClient As Object
      Dim strClient As String
      Dim strToday As Date
      strToday = Date
      Application.ScreenUpdating = False
      Application.Calculation = xlCalculationManual
  
       'Make sure emails are unique
      Set objEmailTo = CreateObject("Scripting.Dictionary")
  
      lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
  
      For Each rngMyCell In Worksheets("Sheet1").Range("C3:C" &amp; lngLastRow)
          If Len(rngMyCell) &gt; 0 Then
              If objEmailTo.Exists(CStr(rngMyCell)) = False Then
                  objEmailTo.Add CStr(rngMyCell), rngMyCell
              End If
          End If
      Next rngMyCell
  
      strEmailTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objEmailTo.Items)), ";")
  
       'Make sure cc emails are unique
      Set objCCTo = CreateObject("Scripting.Dictionary")
  
      lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
  
      For Each rngMyCell In Worksheets("Sheet1").Range("D3:D" &amp; lngLastRow)
          If Len(rngMyCell) &gt; 0 Then
              If objCCTo.Exists(CStr(rngMyCell)) = False Then
                  objCCTo.Add CStr(rngMyCell), rngMyCell
              End If
          End If
      Next rngMyCell
  
      strCCTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objCCTo.Items)), ";")
  
      'Make sure contacts are unique
      Set objContact = CreateObject("Scripting.Dictionary")
  
      lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row
  
      For Each rngMyCell In Worksheets("Sheet1").Range("E3:E" &amp; lngLastRow)
          If Len(rngMyCell) &gt; 0 Then
              If objContact.Exists(CStr(rngMyCell)) = False Then
                  objContact.Add CStr(rngMyCell), rngMyCell
              End If
          End If
      Next rngMyCell
  
      strContact = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objContact.Items)), ";")
  
      'Make sure admins are unique
      Set objAdmin = CreateObject("Scripting.Dictionary")
  
      lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "G").End(xlUp).Row
  
      For Each rngMyCell In Worksheets("Sheet1").Range("G3:G" &amp; lngLastRow)
          If Len(rngMyCell) &gt; 0 Then
              If objAdmin.Exists(CStr(rngMyCell)) = False Then
                  objAdmin.Add CStr(rngMyCell), rngMyCell
              End If
          End If
      Next rngMyCell
  
      strAdmin = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objAdmin.Items)), ";")
  
      'Make sure clients are unique
      Set objClient = CreateObject("Scripting.Dictionary")
  
      lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
  
      For Each rngMyCell In Worksheets("Sheet1").Range("B3:B" &amp; lngLastRow)
          If Len(rngMyCell) &gt; 0 Then
              If objClient.Exists(CStr(rngMyCell)) = False Then
                  objClient.Add CStr(rngMyCell), rngMyCell
              End If
          End If
      Next rngMyCell
  
      strClient = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objClient.Items)), ";")
  
      Application.ScreenUpdating = True
      strbody = "Dear " &amp; strContact &amp; "," &amp; vbNewLine &amp; vbNewLine &amp; _
      "Say Hello World!" &amp; vbNewLine &amp; vbNewLine &amp; _
      "Kind Regards," &amp; vbNewLine &amp; _
      "Mr A Nother"
  
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
  
      On Error Resume Next
              With OutMail
                      .To = strEmailTo
                      .CC = strCCTo
                      .BCC = ""
                      .Subject = strToday &amp; " - Agreement"
                      .Body = strbody
                      '.Attachments.Add
                      .Display
               End With
      On Error GoTo 0
      Set OutMail = Nothing
      Set OutApp = Nothing
  
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
  
  End Sub
  </code></pre>