Option Explicit
Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
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
Const strWorkSheetName As String = "Sheet2"
Const strWorkBookName As String = "C:\Users\ko98240\Desktop\Book1.xlsx" 'the path of the workbook
'Use FileExists function to determine the availability of the workbook
If Not FileExists(strWorkBookName) Then Exit Sub
'Get Excel if it is running, or open it if not
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
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(strWorkBookName)
Set xlSheet = xlWB.Sheets("Sheet1")
'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))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Switchgear:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Other:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("G" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Revisions:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
'If InStr(1, vText(i), "Destination City:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("I" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Destination State:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("J" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Destination Zip:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("K" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Vehicle Type:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("L" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Vehicle Year:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("M" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Vehicle Make:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("N" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Vehicle Model:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("O" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Vehicle Condition:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("P" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Comments:") > 0 Then
'vItem = Split(vText(i), Chr(58))
'xlSheet.Range("Q" & rCount) = Trim(vItem(1))
'End If
Next i
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
I'm encountering the error with this line: