title: access dynamic email address selection
body: <p>I am trying to send email to multiple person. But the email address that it should select is based on the user who has logged in. How do i do this? I have a table where I have 5 columns of email ID. Based on who is logged in, the code should go n select that person and send email to all the person in that row. </p>
  
  <p>How do I achieve this? I know how to do in excel but access I am less aware. I am pasting both the codes I know and hv tried. </p>
  
  <p><div class="snippet" data-lang="js" data-hide="false">
  <div class="snippet-code">
  <pre class="snippet-code-html lang-html prettyprint-override"><code>Sub Mail_ActiveSheet()
         
      Dim OutApp As Object
      Dim Outmail As Object
      Dim sTo As String
      Dim sCC As String
      Dim lastrow, i As Integer
      Dim sub1, sub2, sub3, body1 As Variant
      Dim emailid, cc1, cc2, cc3, cc4, subj, attch, Sourcewb, Outnail, Soucrwb As Object
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.DisplayAlerts = False
      ThisWorkbook.Activate
  'Code for Email sheet creation
      Call EMAILSHEET_DATA
  'Code for emailing schedular to the associates
      Worksheets("Email_List").Select
      lastrow = ThisWorkbook.Worksheets("Email_List").Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
      For i = 2 To lastrow
              Set emailid = Worksheets("Email_List").Range("C" &amp; i)
              sTo = emailid
          Set cc1 = Worksheets("Email_List").Range("D" &amp; i)
          'Set cc2 = Worksheets("Email_List").Range("E" &amp; i)
          'body1 = Worksheets("Email_List").Range("a" &amp; i)
          sCC = cc1 '&amp; ";" &amp; cc2
          subj1 = Worksheets("Email_List").Range("F" &amp; i).Value
          subj2 = Worksheets("Email_List").Range("G" &amp; i).Value
          subj3 = Worksheets("Email_List").Range("H" &amp; i).Value
          subj = "Your Schedule for " &amp; subj1 &amp; subj2 &amp; subj3
          ActiveWorkbook.Activate
          Set Sourcewb = ActiveWorkbook
          Set OutApp = CreateObject("Outlook.Application")
          Set Outmail = OutApp.CreateItem(0)
          On Error Resume Next
          With Outmail
              .To = sTo
              .CC = sCC
              '.BCC=Sbcc
              .Subject = subj
              .Body = "Hello " &amp; Worksheets("Email_List").Range("a" &amp; i).Value &amp; "," &amp; vbCrLf &amp; vbCrLf &amp; subj &amp; "." _
              &amp; vbCrLf &amp; vbCrLf &amp; Worksheets("Email_List").Range("i" &amp; i).Value _
              &amp; vbCrLf &amp; Worksheets("Email_List").Range("j" &amp; i).Value _
              &amp; vbCrLf &amp; Worksheets("Email_List").Range("k" &amp; i).Value _
              &amp; vbCrLf &amp; Worksheets("Email_List").Range("l" &amp; i).Value _
              &amp; vbCrLf &amp; Worksheets("Email_List").Range("m" &amp; i).Value _
              &amp; vbCrLf &amp; Worksheets("Email_List").Range("n" &amp; i).Value _
              &amp; vbCrLf &amp; Worksheets("Email_List").Range("o" &amp; i).Value _
              &amp; vbCrLf &amp; vbCrLf &amp; "Note: Please report any scheduling conflicts or errors to your Supervisor." _
              &amp; vbCrLf &amp; vbCrLf &amp; "Thank You," &amp; vbCrLf &amp; "gmail.com Management"
              .Send
          End With
          On Error GoTo 0
          Set Outmail = Nothing
          Set OutApp = Nothing
          'ActiveWorkbook.Close False
          Application.ScreenUpdating = True
          Application.EnableEvents = True
          Application.DisplayAlerts = True
      Next i
      ThisWorkbook.Activate
      MsgBox ("Thank You! The Schedules have been sent to all the associates.")
  End Sub
  
  'DATA FOR EMAIL SHEET
  Sub EMAILSHEET_DATA()
      Worksheets("Email_list").Select
      Range("A2").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Range(Selection, Selection.End(xlDown)).Select
      Selection.ClearContents
      Worksheets("Schedules").Select
      Range("B15").Select
      Range(Selection, Selection.End(xlDown)).Select
      Selection.Copy
      Sheets("Email_List").Select
      Range("A2").Select
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
      Range("B2").Select
      Application.CutCopyMode = False
      ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
      Range("C2").Select
      ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,3,0)"
      Range("D2").Select
      ActiveCell.FormulaR1C1 = "=VLOOKUP(RC1,Associate_Info!R1C1:R270C7,4,0)"
      Range("E2").Select
      'ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],Associate_Info!C[-4]:C[-1],4,0)"
      ActiveCell.FormulaR1C1 = "Information not available"
      Range("F2").Select
      ActiveCell.FormulaR1C1 = "=Schedules!R12C5"
      Range("G2").Select
      ActiveCell.FormulaR1C1 = "  to  "
      Range("H2").Select
      ActiveCell.FormulaR1C1 = "=Schedules!R12C17"
      Range("I2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C5,""MM/DD/YY"") &amp; "" , "" &amp; Schedules!R13C5 &amp; "" , "" &amp; Schedules!R[13]C[-4] &amp;  "" - "" &amp; Schedules!R[13]C[-3]"
      Range("J2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C7,""MM/DD/YY"")  &amp; "" , "" &amp; Schedules!R13C7 &amp; "" , "" &amp; Schedules!R[13]C[-3] &amp;  "" - "" &amp; Schedules!R[13]C[-2]"
      Range("K2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C9,""MM/DD/YY"")  &amp; "" , "" &amp; Schedules!R13C9 &amp; "" , "" &amp; Schedules!R[13]C[-2] &amp;  "" - "" &amp; Schedules!R[13]C[-1]"
      Range("L2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C11,""MM/DD/YY"")  &amp; "" , "" &amp; Schedules!R13C11 &amp; "" , "" &amp; Schedules!R[13]C[-1] &amp;  "" - "" &amp; Schedules!R[13]C[0]"
      Range("M2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C13,""MM/DD/YY"")  &amp; "" , "" &amp; Schedules!R13C13 &amp; "" , "" &amp; Schedules!R[13]C &amp;  "" - "" &amp; Schedules!R[13]C[1]"
      Range("N2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C15,""MM/DD/YY"")  &amp; "" , "" &amp; Schedules!R13C15 &amp; "" , "" &amp; Schedules!R[13]C[1] &amp;  "" - "" &amp; Schedules!R[13]C[2]"
      Range("O2").Select
      ActiveCell.FormulaR1C1 = _
          "=TEXT(Schedules!R12C17,""MM/DD/YY"")  &amp; "" , "" &amp; Schedules!R13C17 &amp; "" , "" &amp; Schedules!R[13]C[2] &amp;  "" - "" &amp; Schedules!R[13]C[3]"
      Range("O2").Select
      Selection.End(xlToLeft).Select
      Range("B2").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Selection.Copy
      Range("A2").Select
      lastrow = Cells(2, 1).End(xlDown).Row
      'Range("B2:O" &amp; lastrow).Select
      Range("b3:o" &amp; lastrow).Select
      'Range("B3:B571").Select
      'Range("B571").Activate
      Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
          SkipBlanks:=False, Transpose:=False
      Selection.End(xlUp).Select
      Range("B2").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Range(Selection, Selection.End(xlDown)).Select
      Application.CutCopyMode = False
      Selection.Copy
      Selection.End(xlUp).Select
      Range("B2").Select
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
          
          Range("A1").Select
      Range(Selection, Selection.End(xlToRight)).Select
      Application.CutCopyMode = False
      Selection.AutoFilter
      ActiveSheet.Range("$A$1:$O$291").AutoFilter Field:=2, Criteria1:="#N/A"
      Rows("6:6").Select
      Range(Selection, Selection.End(xlDown)).Select
      Selection.Delete Shift:=xlUp
      Selection.AutoFilter
      Range("A1").Select
      ActiveWorkbook.Save
  End Sub</code></pre>
  </div>
  </div>
  </p>
  
  <p><div class="snippet" data-lang="js" data-hide="false">
  <div class="snippet-code">
  <pre class="snippet-code-html lang-html prettyprint-override"><code>Public Sub EmailList()
  'late Binding
  Dim olApp As Object
  Dim olemail As Object
  Dim strbody As String
  
  'creating new outlook instance
  Set olApp = CreateObject("Outlook.Application")
  Set olemail = olApp.CreateItem(0)
  
  strbody = "&lt;html&gt; &lt;body&gt; Hi " &amp; Me.FullName &amp; " &lt;br/&gt; &lt;br/&gt; Your leaves have been saved.  &lt;br/&gt; Start Date: " &amp; Me.Text8 &amp; " &lt;br/&gt; End Date: " &amp; Me.Text10 &amp; " &lt;br/&gt; &lt;br/&gt; Regards &lt;br/&gt; Walmart.com Management "
  
  Set olApp = CreateObject("Outlook.Application")
  Set olemail = olApp.CreateItem(0)
  With olemail
  .BodyFormat = 2
  .Display
  .htmlBody = strbody
  .to = "reetika.choudhary@gmail.com"
  .Subject = "Leaves Applied"
  
  .Send
  DoCmd.SetWarnings WarningsOff
  
  End With
  
  End Sub</code></pre>
  </div>
  </div>
  </p>
  
  <p>excel code is as below: </p>
  
  <p>Any help will be highly appreciated! Thanks in advance.</p>