hi, i am trying already weeks getting this done, but with no succses can any one help me with this?
what i have is this,
i am getting emails from sample@example.com in the body of the email, it looks like this,
new customer
customer name: john smith
customer phone: 123-456-7890
customer ID: 123-444444
i am having an excel sheet named test.xlsx in sheet1 i am having on colmn A each customer ID
what i need is, each time i receive an email from sample@example.com then it should look into the body of the email and get me the customer id into my excel sheet automaticly, i tried to write a VBA but i am having lots of errors, i am going to share it here and maybe some1 can help me with a solution.
problem 1) this email works only if i had selected that specific email, what i need is that it should detect by itsel which email needs to be extracted.
problem 2) it shuts down my excel sheet, when i need that up all the time, so how can i run that macro and it should not have to reopen that excel or shutdown?
here is my code
Option Explicit
Sub CopyToExcel()
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\xxx\Desktop\Test.xlsx" 'the path of the workbook
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
For Each olMail In Fldr.Items
If InStr(olMail.Body, "new customer!") > 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")
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
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), "customer ID:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Next olItem
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
what i have is this,
i am getting emails from sample@example.com in the body of the email, it looks like this,
new customer
customer name: john smith
customer phone: 123-456-7890
customer ID: 123-444444
i am having an excel sheet named test.xlsx in sheet1 i am having on colmn A each customer ID
what i need is, each time i receive an email from sample@example.com then it should look into the body of the email and get me the customer id into my excel sheet automaticly, i tried to write a VBA but i am having lots of errors, i am going to share it here and maybe some1 can help me with a solution.
problem 1) this email works only if i had selected that specific email, what i need is that it should detect by itsel which email needs to be extracted.
problem 2) it shuts down my excel sheet, when i need that up all the time, so how can i run that macro and it should not have to reopen that excel or shutdown?
here is my code
Option Explicit
Sub CopyToExcel()
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\xxx\Desktop\Test.xlsx" 'the path of the workbook
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
For Each olMail In Fldr.Items
If InStr(olMail.Body, "new customer!") > 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")
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
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), "customer ID:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Next olItem
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
