Here is the code I have which now won't pull but one email at a time
Sub eaddrtosuppr()
On Error GoTo ErrHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objNSpace As Object
Set objNSpace = objOutlook.GetNamespace("MAPI")
Dim oAccount As Account
Dim item As Object
Dim procfolder As Folder
Dim iRows, iCols, i As Integer
Dim rng As Range
Dim lastrow As Long
Dim NArray, firstname, lastname As String
Dim wb As Workbook
Dim ws As Worksheet
Dim Rdate As Date
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Friday")
Sheets("Friday").UsedRange.Clear
'Set rng = ActiveSheet.UsedRange
' Set rng = ws.UsedRange
'lastrow = rng.Rows(ActiveSheet.UsedRange.Rows.Count).Row
'lastrow = ActiveSheet.ListObjects("Unsubs").Range.Rows.Count
'iRows = lastrow + 1
iRows = 2
Set procfolder = objNSpace.Folders("Main").Folders("Inbox").Folders("Requests")
For Each item In procfolder.Items
Cells(iRows, 1) = item.SenderEmailAddress 'Email Address from email request
Cells(iRows, 5) = "End User" 'type of customer
Cells(iRows, 6) = "Email" 'Channel that request came in by
Cells(iRows, 7) = "Customer Support" ' Business function from record of truth
Cells(iRows, 8) = "Type" ' Type of Request
' Cells(iRows, 9) = "Request - " ' Add name of person called after pull
Cells(iRows, 10) = item.ReceivedTime 'date and time email request was received
Cells(iRows, 11) = item.Subject & vbCrLf & item.Body 'email subject and body test to be used as long description in record of truth
Cells(iRows, 12) = "Out" 'Marketing
Cells(iRows, 13) = "Out" 'Target
Cells(iRows, 14) = "" 'Service ? to be provided by MKTing
Cells(iRows, 15) = "" 'Suppress all? to be provided by MKTing
Cells(iRows, 16) = "Yes" '? to be provided by MKTing
Cells(iRows, 17) = "" 'Stop ? to be provided by MKTing
Cells(iRows, 18) = "" 'X Account? to be provided by CS
Cells(iRows, 19) = "" 'Z Account? to be provided by CS
Cells(iRows, 20) = "" 'Country to be provided by CS
Cells(iRows, 21) = "" 'State if Yes to Country
Cells(iRows, 22) = "" 'Device Linked? to be provided by CS
Cells(iRows, 23) = "" 'Device type? to be provided by CS
Cells(iRows, 24) = "" 'Delete? to be provided by CS
Cells(iRows, 25) = "" 'Comments provided by MKTing & CS
Cells(iRows, 27) = "Request - Customer - Case Management"
'H206+7-WEEKDAY(H206+1)
Rdate = item.ReceivedTime + 8 - Weekday(item.ReceivedTime, vbFriday)
Cells(iRows, 26) = Rdate 'Date resolved
i = iRows
GetName (item.Body) 'Passing email body to below function and then extracts name returning value back to top function
Cells(iRows, 2) = NM
NArray = Split(NM, " ", 2)
Cells(iRows, 3) = NArray(0)
Cells(iRows, 4) = NArray(1)
Cells(iRows, 9) = "Request - " & NM ' Add name of person
iRows = iRows + 1
Next
ErrHandler:
Debug.Print Err.Description
End Sub
____________________________________________
Private Function GetName(EmailBody As String) As String
Dim Ar As Variant
Dim i As Long
Dim L As Integer
' Dim NM As String
'~~> Split the body text into an array
'~~> If vbNewLine doesn't work then try vbCrLf or vbLf
Ar = Split(EmailBody, vbNewLine)
'~~> Loop through the array and find the line which has "My name is"
For i = LBound(Ar) To UBound(Ar)
If InStr(1, Ar(i), "My name is ", vbTextCompare) Then
'~~> Extract name
NM = Split(Ar(i), "My name is ")(1)
L = Len(NM) - 1
NM = Left(NM, L)
' MsgBox (NM)
Exit For
____________________________________
New email is now coming in with a table that I need to extract the name and email out of along with other alternative emails if they exist.