Email Scrub and Sort

[aworthey]

Option Explicit


Sub CopyToExcel(olItem As MailItem)

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim gaFolder As Folder
Dim teFolder As Folder
Dim vText As Variant
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long
Dim bXStarted As Boolean
Dim ga As String, te As String, sg As String, ot As String, re As String
Dim ga2 As String, te2 As String, sg2 As String, ot2 As String, re2 As String
Const strWorkSheetName As String = "Sheet2"
Const strWorkBookName As String = "C:\Users\ko98240\Desktop\Book1.xlsm" 'the path of the workbook

Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set teFolder = olFolder.Folders("Tank & Enclosure")
Set gaFolder = olFolder.Folders("Generator and ATS")

'Open the workbook to input the data
Set xlWB = Excel.Workbooks.Open("C:\Users\ko98240\Desktop\Book1.xlsm")
Set xlSheet = xlWB.Sheets("Sheet2")

'Process the message
With olItem
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1

'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Job Name:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If

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

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

If InStr(1, vText(i), "Generator and ATS:") > 0 Then
vItem = Split(vText(i), Chr(58))
ga = "Generator and ATS: " & Trim(vItem(1))
ga2 = Trim(vItem(1))
End If

If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then
vItem = Split(vText(i), Chr(58))
te = "Tank & Enclosure: " & Trim(vItem(1))
te2 = Trim(vItem(1))
End If

If InStr(1, vText(i), "Switchgear:") > 0 Then
vItem = Split(vText(i), Chr(58))
sg = "Switchgear: " & Trim(vItem(1))
sg2 = Trim(vItem(1))
End If

If InStr(1, vText(i), "Other:") > 0 Then
vItem = Split(vText(i), Chr(58))
ot = "Other: " & Trim(vItem(1))
ot2 = Trim(vItem(1))
End If

If InStr(1, vText(i), "Revisions:") > 0 Then
vItem = Split(vText(i), Chr(58))
re = "Revisions: " & Trim(vItem(1))
re2 = Trim(vItem(1))
End If

Next i

'Move the incoming email to appropriate sub inbox
If ((Len(ga2) > 0) And (Len(te2) = 0)) Then
olItem.Move gaFolder

ElseIf ((Len(sg2) > 0) And (Len(te2) = 0)) Then
olItem.Move gaFolder

ElseIf ((Len(ot2) > 0) And (Len(te2) = 0)) Then
olItem.Move gaFolder

ElseIf ((Len(re2) > 0) And (Len(te2) = 0)) Then
olItem.Move gaFolder

Else
olItem.Move teFolder
End If

'Copy notes to one note field
xlSheet.Range("D" & rCount) = ga & " " & te & " " & sg & " " & ot & " " & re

'Separate date and time from time stamp
xlSheet.Range("E" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy")
xlSheet.Range("F" & rCount) = Format(olItem.ReceivedTime, "hh:mm:ss AM/PM")

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