How to copy and append data from Outlook 2016 message into Excel 2016 workbook

[Pam Fim]

I'm new to working with VBA and need to copy data from multiple emails in a folder. I used the Use a macro to copy data in Outlook email to Excel workbook example to create the VBA code and it does not place the data in the Excel 2016 workbook for any emails in the Occupant folder.

Questions
1. Why is the data not placed in the test3.xlsx workbook from emails in the Occupant folder?
2. How can I update the VBA code to add multiple data sets in one email thread?
3. How do you update the code to update the test3.xlsx workbook as each time an email appears in the Occupant folder from new incoming email or an email moved or copied to the folder to appear in the next blank row of the test3.xlsx workbook?


Email data sample
Occupant-Company ID: 71xxxxx7-xxxx-xxxx-xxxx-8xxxxxxxxxxd
Occupant.COM: GoData2383405.GoData.com
Company name: Go Data
Domain(s): GoData.com; Data.com
Contact Name: Frank GoData
Contact Email Address: frank4@godata.com
Contact Phone Number: 999-978-9090

Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items

Private Sub Application_Startup()

Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")

'Set the folder and items to watch:
' Use this for a folder in your default data file
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Occupant")

' to watch a folder in a non-default data file
' see Working with VBA and non-default Outlook Folders for GetFolderPath Function
' Set objWatchFolder = GetFolderPath("me@domain.com\Inbox\Occupant")

Set objItems = objWatchFolder.Items

Set objWatchFolder = Nothing
End Sub


Private Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7 As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As Object
Dim M1 As Object
Dim M As Object
Dim i As Integer
Dim strResult As String

enviro = CStr(Environ("USERPROFILE"))

'the path of the workbook
strPath = enviro & "\Documents\test3.xlsx"
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")

'Find the next empty line of the worksheet
rCount = rCount + 1

sText = olItem.Body
Set Reg1 = CreateObject("VBScript.RegExp")
For i = 1 To 7

With Reg1

Select Case i
' Occupant-Company ID: start entering data in cell A-2 or the next blank row
Case 1 ' include notes on text content format
.Pattern = "(Occupant-CompanyID\s[:]+\s*(\w*)\s*)\n"
.Global = False

' Occupant.Com(s): start entering data in cell B-2 or the next blank row
Case 2 ' include notes on text content format
.Pattern = "( Occupant.Com(s)\s[:]+\s*(\w*)\s*)\n"
.Global = False

' Company Name: start entering data in cell C-2 or the next blank row
Case 3 ' include notes on text content format
.Pattern = "(Company Name\s[:]+\s*(\w*)\s*)\n"
.Global = False

' Domain(s): start entering data in cell D-2 or the next blank row
Case 4 ' include notes on text content format
.Pattern = "(Domain(s)\s[:]+\s*(\w*)\s*)\n"
.Global = False

' Contact Name: start entering data in cell E-2 or the next blank row
Case 5
.Pattern = "(Contact Name\s[:]+\s*(\w*)\s*)\n"
.Global = False

' Email Address: start entering data in cell F-2 or the next blank row
Case 6
.Pattern = "(Email Address\s[:]+\s*(\w*)\s*)\n"
.Global = False

' Contact Phone Number: start entering data in cell G-2 or the next blank row
Case 7
.Pattern = "(Contact Phone Number\ s*(.*))\n "
.Global = False

End Select

End With

If Reg1.Test(sText) Then

Set M1 = Reg1.Execute(sText)
For Each M In M1

Debug.Print M.SubMatches(1)
strResult = M.SubMatches(1)
If i = 1 Then vText = strResult
If i = 2 Then vText2 = strResult
If i = 3 Then vText3 = strResult
If i = 4 Then vText4 = strResult
If i = 5 Then vText5 = strResult
If i = 6 Then vText6 = strResult
If i = 7 Then vText7 = strResult

Next
End If
Next i
Debug.Print vText
Debug.Print "1: " & vText
Debug.Print "2: " & vText2
Debug.Print "3: " & vText3
Debug.Print "4: " & vText4
Debug.Print "5: " & vText5
Debug.Print "6: " & vText6
Debug.Print "7: " & vText7

xlSheet.Range("A" & rCount) = vText
xlSheet.Range("B" & rCount) = vText2
xlSheet.Range("C" & rCount) = vText3
xlSheet.Range("D" & rCount) = vText4
xlSheet.Range("E" & rCount) = vText5
xlSheet.Range("F" & rCount) = vText6
xlSheet.Range("G" & rCount) = vText7

xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub


Sub TestMacro()
Dim olItem As Outlook.MailItem
Set olItem = Application.ActiveExplorer.Selection.Item(1)
CopyToExcel olItem
End Sub