access dynamic email address selection - excel

Question

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.
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.
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" & i)
sTo = emailid
Set cc1 = Worksheets("Email_List").Range("D" & i)
'Set cc2 = Worksheets("Email_List").Range("E" & i)
'body1 = Worksheets("Email_List").Range("a" & i)
sCC = cc1 '& ";" & cc2
subj1 = Worksheets("Email_List").Range("F" & i).Value
subj2 = Worksheets("Email_List").Range("G" & i).Value
subj3 = Worksheets("Email_List").Range("H" & i).Value
subj = "Your Schedule for " & subj1 & subj2 & 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 " & Worksheets("Email_List").Range("a" & i).Value & "," & vbCrLf & vbCrLf & subj & "." _
& vbCrLf & vbCrLf & Worksheets("Email_List").Range("i" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("j" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("k" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("l" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("m" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("n" & i).Value _
& vbCrLf & Worksheets("Email_List").Range("o" & i).Value _
& vbCrLf & vbCrLf & "Note: Please report any scheduling conflicts or errors to your Supervisor." _
& vbCrLf & vbCrLf & "Thank You," & vbCrLf & "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"") & "" , "" & Schedules!R13C5 & "" , "" & Schedules!R[13]C[-4] & "" - "" & Schedules!R[13]C[-3]"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C7,""MM/DD/YY"") & "" , "" & Schedules!R13C7 & "" , "" & Schedules!R[13]C[-3] & "" - "" & Schedules!R[13]C[-2]"
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C9,""MM/DD/YY"") & "" , "" & Schedules!R13C9 & "" , "" & Schedules!R[13]C[-2] & "" - "" & Schedules!R[13]C[-1]"
Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C11,""MM/DD/YY"") & "" , "" & Schedules!R13C11 & "" , "" & Schedules!R[13]C[-1] & "" - "" & Schedules!R[13]C[0]"
Range("M2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C13,""MM/DD/YY"") & "" , "" & Schedules!R13C13 & "" , "" & Schedules!R[13]C & "" - "" & Schedules!R[13]C[1]"
Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C15,""MM/DD/YY"") & "" , "" & Schedules!R13C15 & "" , "" & Schedules!R[13]C[1] & "" - "" & Schedules!R[13]C[2]"
Range("O2").Select
ActiveCell.FormulaR1C1 = _
"=TEXT(Schedules!R12C17,""MM/DD/YY"") & "" , "" & Schedules!R13C17 & "" , "" & Schedules!R[13]C[2] & "" - "" & 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" & lastrow).Select
Range("b3:o" & 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
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 = "<html> <body> Hi " & Me.FullName & " <br/> <br/> Your leaves have been saved. <br/> Start Date: " & Me.Text8 & " <br/> End Date: " & Me.Text10 & " <br/> <br/> Regards <br/> 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
excel code is as below:
Any help will be highly appreciated! Thanks in advance.

Answer 1

You can use Environ("USERNAME") on a windows system to pull the username from the environment variables:
Sub SO()
Dim username As String
username = Environ("USERNAME")
MsgBox username & " is currently logged on."
End Sub