Option Explicit
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 vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\Rob\Documents\Excel\Excel.xlsx" '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("Sheet1")
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
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
If InStr(1, vText(i), "Destination -") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("a" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
This code is from online where I tried making it work for myself...
I need to extract Specific Data from emails (over 5000) and produce them on an Excel document. I've never touched VBA before only C#, Javascript & C++.
The code runs, the excel sheet updates to the current Date/time but nothing is produced?
Any help please?
I also get an error "Subscript out of range" for this line:
xlSheet.Range("A" & rCount) = Trim(vItem(1))
I think you need to change the second split delimiter to match the first one. This will take care of the Subscript error
Use this:
vItem = Split(vText(i), "Destination -")
Related
Im newbiee in VBA, so i need a little help.
My goal is make an Outlook rule, but i have a problem:
I want to save one excel (xlsx) file from my Outlook Inbox to my PC. But only the file which contains (in spreadsheet) a string. But it saves (or not saving anything) the last excel file.. (not checking for MYSTRING)
Using this code:
Option Explicit
Sub CheckAttachments(olItem As MailItem)
Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\"
Const strFindText As String = "Completed"
Dim strFilename As String
Dim olAttach As Attachment
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim bFound As Boolean
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Right(LCase(olAttach.FileName), 4) = "xlsx" Then
strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
Chr(32) & olAttach.FileName
olAttach.SaveAsFile strFilename
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 read the data
Set xlWB = xlApp.Workbooks.Open(strFilename)
Set xlSheet = xlWB.Sheets("Sheet1")
If FindValue(strFindText, xlSheet) Then
MsgBox "Value found in " & strFilename
bFound = True
End If
xlWB.Close 0
If bXStarted Then xlApp.Quit
If Not bFound Then Kill strFilename
Exit For
End If
Next olAttach
End If
End Sub
Function FindValue(FindString As String, iSheet As Object) As Boolean
Dim Rng As Object
If Trim(FindString) <> "" Then
With iSheet.Range("A:J")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=-4163, _
LookAt:=1, _
SearchOrder:=1, _
SearchDirection:=1, _
MatchCase:=False)
If Not Rng Is Nothing Then
FindValue = True
Else
FindValue = False
End If
End With
End If
End Function
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
CheckAttachments olMsg
End Sub
I think I found your Problem:
You have used Exit For in your For Loop only. So only after scanning 1st file, loop is exited.
You need to remove the Exit For and then your code will work smoothly.
Option Explicit
Sub CheckAttachments(olItem As MailItem)
Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\"
Const strFindText As String = "Completed"
Dim strFilename As String
Dim olAttach As Attachment
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim bFound As Boolean
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Right(LCase(olAttach.FileName), 4) = "xlsx" Then
strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
Chr(32) & olAttach.FileName
olAttach.SaveAsFile strFilename
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 read the data
Set xlWB = xlApp.Workbooks.Open(strFilename)
Set xlSheet = xlWB.Sheets("Sheet1")
If FindValue(strFindText, xlSheet) Then
MsgBox "Value found in " & strFilename
bFound = True
End If
xlWB.Close 0
If bXStarted Then xlApp.Quit
If Not bFound Then Kill strFilename
End If
Next olAttach
End If
End Sub
Function FindValue(FindString As String, iSheet As Object) As Boolean
Dim Rng As Object
If Trim(FindString) <> "" Then
With iSheet.Range("A:J")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=-4163, _
LookAt:=1, _
SearchOrder:=1, _
SearchDirection:=1, _
MatchCase:=False)
If Not Rng Is Nothing Then
FindValue = True
Else
FindValue = False
End If
End With
End If
End Function
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
CheckAttachments olMsg
End Sub
If I use the below code to close all instances of Excel that are currently open what would I need to use to reopen all the instances of Excel that were just closed? I know I'll have to change the below to save a filepath somewhere but just not sure what the actual code should be.
Public Sub CloseAllExcel()
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
wb.Save
wb.Close
Next
xl.Quit
Set xl = Nothing
Loop
Exit Sub
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
This stores file paths of the workbooks to a text file. If you run this macro with False as the input, this will open all of the recently closed files. (Not tested)
Public Sub CloseAllExcel(Closing As Boolean)
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim strPath As String
strPath = "C:\path.txt"
If Close Then
Dim fso as Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile as Object
Set oFile = FSO.CreateTextFile(strPath)
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
oFile.WriteLine Application.ActiveWorkbook.FullName
wb.Save
wb.Close
Next
oFile.Close
Set fso = Nothing
Set oFile = Nothing
xl.Quit
Set xl = Nothing
Loop
Exit Sub
Else
Dim FileNum As Integer
Dim DataLine As String
FileNum = FreeFile()
Open strPath For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
Workbooks.Open DataLine
Wend
Exit Sub
End If
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
You could use a Very-Hidden worksheet, where you'll keep all of the Files currently open.
Note: If you want there is an option to Save and Read for the Registry.
Sub CloseAllExcel Code:
Option Explicit
Public Sub CloseAllExcel()
On Error GoTo handler
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim Hidws As Worksheet
On Error Resume Next
Set Hidws = ThisWorkbook.Worksheets("Admin")
On Error GoTo 0
If Hidws Is Nothing Then ' check if there isn't "Admin" sheet exists in the workbook
Set Hidws = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Worksheets(Worksheets.Count))
Hidws.Name = "Admin"
Hidws.Visible = xlSheetVeryHidden ' make the "Admin" sheet very-hidden
End If
i = 1
Do While xlApp Is Nothing
Set xlApp = GetObject(, "Excel.Application")
For Each wb In xlApp.Workbooks
Hidws.Range("A" & i).Value = wb.FullName ' save each workbook full name and path in column "A" in "Admin" very-hidden sheet
i = i + 1
wb.Close True
Next
xlApp.Quit
Set xlApp = Nothing
Loop
Exit Sub
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
Sub RestoreExcelLastSession Code: reads the files (names and Path) from Column "A" in "Admin" very-hidden sheet.
Sub RestoreExcelLastSession()
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim Hidws As Worksheet
On Error Resume Next
Set Hidws = ThisWorkbook.Worksheets("Admin")
On Error GoTo 0
If Hidws Is Nothing Then ' check if "Admin" sheet exists
MsgBox "No Files have been restored"
Exit Sub
End If
i = 1
Do While Hidws.Range("A" & i).Value <> "" ' loop through cells in Column "A"
Set xlApp = CreateObject("Excel.Application") ' open a new Excel instance per file
xlApp.Workbooks.Open (Hidws.Range("A" & i).Value)
i = i + 1
Set xlApp = Nothing
Loop
End Sub
So this has come up before, but the only answers given were to use Regular Expressions, but it's not making sense to me.
I already have a module that is copying text out of selected emails and dumping it into a CSV, I need it to also count instances of a certain string of text and also dump that count. What I have I bastardized from code I found here:
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 vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String =
"F:\Scripting\Export\AEX_JUNIPER_LOGGING\Input\orders.csv" '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("orders")
xlSheet.Rows(2 & ":" & xlSheet.Rows.Count).ClearContents
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
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
If InStr(1, vText(i), "JOBID:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "RMA Number : ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "DESTINATION WAREHOUSE : ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "TRACKING NUMBER : ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
How can I amend this to include the new code I need?
Without using regex, you can find the number of occurrences of a substring (subStr) within a string (str) using a similar algorithm as follows:
'Replaces all instances of substring with nothing, effectively removing all instances of it
newStr = Replace(str, subStr, "")
'Determine how many instances were removed
instancesOfSubStr = (len(str) - len(newStr)) / len(subStr)
At this point I imagine you can just accumulate it in a global variable after processing each cell.
I'm trying to run my code using rule script to only processes newly arrived message but it keeps throwing Error
What am I doing wrong on my code?
Option Explicit
Public Sub Test(Item As Outlook.MailItem)
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim XStarted As Boolean
Dim FileName As String
Dim FilePath As String '// SaveAs CSV File Path
Dim sPath As String '// .CSV File Path
'// the path of the workbook
sPath = "C:\temp\temp.csv"
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")
XStarted = True
End If
' On Error GoTo 0
'// Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(sPath)
Set xlSheet = xlWB.Sheets("Report")
'// Process received Mail
sText = Item.Body
vText = Split(sText, Chr(13)) ' Chr(13)) carriage return
'// 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
'// Customer Name
If InStr(1, vText(i), "Customer") > 0 Then
vItem = Split(vText(i), Chr(9)) ' Chr(9) horizontal tab
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
'// Ref Number
If InStr(1, vText(i), "Order #") > 0 Then
vItem = Split(vText(i), Chr(9))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
'// Service Level
If InStr(1, vText(i), "Service Level") > 0 Then
vItem = Split(vText(i), Chr(9))
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
Next i
FilePath = Environ("USERPROFILE") & "\Documents\Temp\"
FileName = Sheets(1).Range("B2").Value
xlWB.SaveAs FileName:=FilePath & FileName
'// Close & SaveChanges
xlWB.Close SaveChanges:=True
If XStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set Item = Nothing
End Sub
Per Patrick.
You may have changed the VBA Project name. Go to Outlook Rules, Edit, re-assign the macro.
Also, it should FileName = xlWB.Sheets(1).Range("B2").Value And get rid of Application.StatusBar = ...
Thanks...
I'm a complete coding novice and I'm struggling with extracting the data out of an email bodies into an Excel 2010 sheet.
The format of the email is;
Form Response
First name John
Surname Smith
Email john.smith#test.com.au
Today's code word test1
I'v been trying my luck at various bits of VBA code I've found online however end up with Subscript out of Range errors when ever it gets to the body of the email;
Option Explicit
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 vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "c:\test\test1.xlsx" '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("Sheet1")
'Process each selected record
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.UsedRange.Rows.Count
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
rCount = rCount + 1
If InStr(1, vText(i), "First name ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Surname:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Today's code word ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
Can anyone offer any help?
Thanks.
i think the Problem is caused by the use of the split-function.
Try this:
fist you need additionally
dim mystart as integer
dim myend as integer
and the delete everything with "vtext" and alter your code like this:
If InStr(1, sText, "First name ") > 0 Then
mystart = InStr(1, sText, "First name ") + 11
myend = InStr(mystart, sText, Chr(10)) - mystart - 1
vItem = mid(sText, mystart, myend)
xlSheet.Range("A" & rCount) = Trim(vItem)
End If
Hope this helps,
Max
What line of code throws an exception? Did you try to debug the code?
I'd recommend starting from the Getting Started with VBA in Outlook 2010 article. Also please remember that indexes start from 1, not 0.