importing email into excel problem
Hi Guys, :hi:
I'm very new to VBA but have been having a lot of fun copying and paste code from some examples. I'm having an issue with importing into excel from an email.
I do not want to import the words "Is this your first visit" rather, I only want the email reply for "Yes" to be imported.
As it sits "Is this your first visit:yes" is imported into my spreadsheet.
Thank you so much for any ideas you may have for a beginner!
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim ss1 As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\jbryer\Desktop\ApplicationImportstest.xlsm" '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(1)
'Process each selected record
'rCount = xlSheet.UsedRange.Rows.Count + 1
rCount = xlSheet.Cells(xlSheet.Rows.Count, "B").End(xlUp).Row
rCount = rCount + 1
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
xlSheet.Range("B" & rCount) = Format(olItem.ReceivedTime, "MM/DD/yyyy hh:mm") 'Date
If InStr(1, vText(i), "Is this your first visit?") > 0 Then
xlSheet.Range("C" & rCount) = Trim(vText(i + 2))
End If
