Looking to export emails from outlook to an excel file

[spittingfire]

Hi All,

I have the below 2 examples (one is a FULL DAY while the other is a PARTIAL DAY) of emails that comes into a specific folder and we need to parse them and export to an excel file.

Each time we export we will first need to delete all rows below the header before adding the new records.

I will need to select and export a few records at a time.

I've attached the output that we are looking for in the excel file.



FULL DAY



Employee Name:
PEEWEE LOZANO


Employee ID:
356352


Contact Phone Number:
4161234567


Location:
ALBERTA


Absence report submitted:
08-25-2017 09:56


Type of Absence:
FULL DAY


Time zone:
Eastern Time


Nature of absence:
NON-SICKNESS


Absence reason:
REGULAR



PARTIAL DAY


Employee Name:
THAMARA HEYWOOD


Employee ID:
326899


Contact Phone Number:
6477654321


Location:
TORONTO


Absence report submitted:
08-25-2017 09:16


Type of Absence:
PARTIAL DAY


Absence start date/time:
08-25-2017 09:00


Absence end date/time:
08-25-2017 10:30


Time zone:
Eastern Time


Total absence duration:
01:30 hours


Nature of absence:
NON-SICKNESS


Absence reason:
REGULAR




Any help in resolving this will be greatly appreciated.

[gmayor]

I covered this in some depth in another forum a while back. The salient points I reproduced at http://www.gmayor.com/extract_data_from_email.htm (http://www.gmayor.com/extract_data_from_email.htm) or http://www.gmayor.com/extract_email_data_addin.htm (http://www.gmayor.com/extract_email_data_addin.htm)

[spittingfire]

Thanks gmayor

Was able to solve it it using the site you provide

My final code is



Sub CopyToExcel_Original()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim strItem As String
Dim bXStarted As Boolean
Const olMailItem As Long = 0
Const strPath As String = "\\******xx\***xxTEST\test.xlsx" 'the path of the workbook


If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
xlSheet.Range("A1:Z500").Clear
xlSheet.Range("A1").Select


With xlSheet
.Cells(1, 1) = "Emp.Name"
.Cells(1, 2) = "Emp. ID"
.Cells(1, 3) = "Location"
.Cells(1, 4) = "Type"
.Cells(1, 5) = "Start Date"
.Cells(1, 6) = "Start Time"
.Cells(1, 7) = "End Date"
.Cells(1, 8) = "End Time"
.Cells(1, 9) = "Zone"
.Cells(1, 10) = "Duration"
.Cells(1, 11) = "Reason"
.Cells(1, 12) = "Memo"
End With

'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Employee Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Employee ID:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Location:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Type of Absence:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Absence start date/time:") > 0 Then
vItem = Split(vText(i), Chr(58))
strItem = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
vItem = Split(strItem, Chr(32)) 'split at the space
xlSheet.Range("E" & rCount) = Trim(vItem(0)) 'the date
xlSheet.Range("F" & rCount) = Trim(vItem(1)) 'the time
End If


If InStr(1, vText(i), "Absence end date/time:") > 0 Then
vItem = Split(vText(i), Chr(58))
strItem = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
vItem = Split(strItem, Chr(32)) 'split at the space
xlSheet.Range("G" & rCount) = Trim(vItem(0)) 'the date
xlSheet.Range("H" & rCount) = Trim(vItem(1)) 'the time
End If


If InStr(1, vText(i), "Time zone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("I" & rCount) = Trim(vItem(1))
End If


If InStr(1, vText(i), "Total absence duration:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("J" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))


End If


If InStr(1, vText(i), "Absence reason:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("K" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Absence report submitted:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("L" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))


End If




Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub