I have the following 2 examples of the type of email that I'm looking to export from MS Outlook. I've included one that is a Full day and another that is a Partial day.
**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
The output into excel that we are looking for is
+-----------------+---------+----------+----------+------------+------------+-----------+----------+--------------+----------+---------+----------------+
| Emp.Name | Emp. ID | Location | Type | Start Date | Start Time | End Date | End Time | Zone | Duration | Reason | Memo |
+-----------------+---------+----------+----------+------------+------------+-----------+----------+--------------+----------+---------+----------------+
| PEEWEE LOZANO | 356352 | TORONTO | FULL DAY | 8/25/2017 | | | | Eastern Time | | REGULAR | 8/25/2017 9:56 |
| THAMARA HEYWOOD | 326899 | TORONTO | | 8/25/2017 | 9:00 | 8/25/2017 | 10:30 | Eastern Time | 1:30 | REGULAR | 8/25/2017 9:16 |
+-----------------+---------+----------+----------+------------+------------+-----------+----------+--------------+----------+---------+----------------+
In addition each time we export we will first need to delete all rows below the header in the excel file before adding the new records.
I will need to select and export a few records at a time.
I'm very new to Outlook VB and don't know where to start. Any help will be greatly appreciated.
After visiting http://www.gmayor.com/extract_data_from_email.htm
I came up with the following solution that worked well
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 = "\\xxxx\xxs\xxxxT\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