I'm new to VBA and I'm having difficulty trying to insert comments from data that I have in Excel onto a Word document. I am trying to write the VBA in Word and want it to extract data from a separate spreadsheet
Sub ConvertCelltoWordComment()
Dim Rng As Range
Dim wApp As Object
Dim strValue As String
Dim xlapp As Object
Dim xlsheet As Object
Dim xlbook As Object
'Opens Excel'
Set xlapp = GetObject("C:\Users\eugenechang\Desktop\...xlsx")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim i As Integer
For i = 1 To 5
With xlsheet
strValue = ActiveSheet.Cells(i, 1).Offset(1, 0)
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next i
End Sub
I'm trying to get it to work, but it is giving me an error "Object not defined". I've tried setting up an object within the strValue line below "With xlsheet", but am hitting a wall. Any help??
You have not assigned anything to xlsheet - so this (by default) equates to Nothing.
Try setting xlSheet to something meaningful. The following is only an example:
For i = 1 To 5
Set xlsheet = xlbook.Worksheets(i) ' <--- example here
With xlsheet
strValue = .Cells(i, 1).Offset(1, 0) '<-- don't use ActiveSheet
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next I
An important note here is that you also have not set xlbook - you must also assign something meaningful to xlbook.
Add a couple DocVariables to your Word file and run the script below, from Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
' etc., etc., etc.
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
This ended up writing comments from an Excel file. Obviously the names have been changed for privacy reasons. Please let me know if I can simplify this better.
Sub ConvertExceltoWordComment()
Dim wApp As Word.Application
Dim xlApp As Excel.Application
Dim PgNum As Integer
Dim LineNum As Integer
Dim objSelection As Word.Document
Dim strpgSearch As Long
Dim strlinSearch As Long
Dim myRange As Range
Dim XlLog As Excel.Worksheet
Dim RowCount As Long
'Opens Copied Word document'
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim SaveDoc As Excel.Workbook
Set SaveDoc = xlApp.Workbooks.Open("FilePath.xlsm") 'Type filepath of document here'
Set XlLog = SaveDoc.Sheets("Worksheet_Name") 'Type Sheetname here'
RowCount = XlLog.Range("A1048576").End(xlUp).Row
If RowCount > 0 Then
Dim iTotalRows As Long
iTotalRows = XlLog.Rows.Count 'Get total rows in the table'
Dim txt As Variant
Dim iRows As Long
End If
Dim i As Integer
'Insert comment into Word document'
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
If Err Then
Set wApp = CreateObject("Word.Application")
End If
Set objSelection = ActiveDocument
For iRows = 3 To iTotalRows
txt = XlLog.Cells(iRows, 8).Text 'Grabs appropriate comment text'
objSelection.Activate
objSelection.SelectAllEditableRanges
strpgSearch = XlLog.Cells(iRows, 2) 'Grabs appropriate Page number'
strlinSearch = XlLog.Cells(iRows, 3) 'Grabs appropriate Line number'
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext,
Name:=strpgSearch
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative,
Count:=strlinSearch
Set myRange = ActiveWindow.Selection.Range
ActiveDocument.Comments.Add Range:=myRange, Text:=txt
Next iRows
Set xlApp = Nothing
Set SaveDoc = Nothing
Set XlLog = Nothing
Set objSelection = Nothing
Set myRange = Nothing
Set wApp = Nothing
SaveDoc.Close
End Sub
Related
I'd like to open a bunch of word files, from a list of file names in my excel workbook, activate the opened word files, perform a text replacement, and save the changes.
I can't make the liaison between Excel VBA and Word files.
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Modify Word Files From a List in Excel
It is assumed that the file names are in column A. It will open each file and replace all occurrences of one string with another.
The focus here is on how to reference (open) Word, open files, modify them (not so much), close them with saving changes, and finally close Word only if it was initially closed.
Option Explicit
Sub VisitWord()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Late Binding (not recommended at this stage)
' When you get familiar with how it works, switch to Late Binding:
' Dim wdApp As Object
' Dim WordWasClosed As Boolean
' On Error Resume Next ' see if Word is open
' Set wdApp = GetObject(, "Word.Application") ' attempt to create a reference to it
' On Error GoTo 0
' If wdApp Is Nothing Then ' Word is not open
' WordWasClosed = True
' Set wdApp = CreateObject("Word.Application") ' open and create a reference to it
' End If
' wdApp.Visible = True ' default is false; outcomment when done testing
' Dim wdDoc As Object
' ' etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Early Binding
' For this to work, in Excel, you need to create a reference to
' Tools > References > Microsoft Word 16.0 Object Library
' Use this to have the Word intellisense work for you.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const WordFolderPath As String = "C:\Test\"
Const FINDSTRING As String = "Old String"
Const REPLACESTRING As String = "New String"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim wdApp As Word.Application
Dim WordWasClosed As Boolean
On Error Resume Next ' see if Word is open
Set wdApp = Word.Application ' attempt to create a reference to it
On Error GoTo 0
If wdApp Is Nothing Then ' Word is not open
WordWasClosed = True
Set wdApp = New Word.Application ' open and create a reference to it
End If
wdApp.Visible = True ' default is false; outcomment when done testing
Dim cell As Range
Dim wdDoc As Word.Document
Dim WordFileName As String
Dim WordFilePath As String
For Each cell In rg.Cells
WordFileName = CStr(cell.Value)
If Len(WordFileName) > 0 Then
WordFilePath = WordFolderPath & WordFileName
If Len(Dir(WordFilePath)) > 0 Then ' file exists
Set wdDoc = wdApp.Documents.Open(WordFilePath)
' Here you do the damage...
wdDoc.Content.Find.Execute _
FindText:=FINDSTRING, _
ReplaceWith:=REPLACESTRING, _
Format:=True, _
Replace:=wdReplaceAll
wdDoc.Close SaveChanges:=True
End If
End If
Next cell
If WordWasClosed Then wdApp.Quit
End Sub
So this is the code i've come up with so far:
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Here is some sample code that I created recently to loop through cells in Excel, which are paths to Word files. Each Word file is opened, scanned for a table (in Word), and copy/paste to Excel. See if you can start with this. Post back if you have additional questions.
Sub LoopThroughAllWordFiles()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim oTbl As Word.Table
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet
Dim cnt As Long
Dim tableCount As Long
Dim lrow As Long
Dim lastrow As Long
Dim file As String
Dim rng As Range, cell As Range
Dim objDoc As Object
Dim objWord As Object
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Set rng = Worksheets("Files").Range("A1:A200")
Worksheets("Word_Tables").Select
filecounter = 1
cnt = 1
Set objWord = CreateObject("Word.Application")
obj.Word.Visible = False
For Each cell In rng.SpecialCells(xlCellTypeVisible)
MyStr = Right(cell, 5)
If MyStr = ".docx" Then
mylength = Len(cell)
pos = InStrRev(cell, "\")
strFolder = Left(cell, pos)
strFile = Right(cell, mylength - pos)
Worksheets("Word_Files").Select
Set objWord = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set sht = ThisWorkbook.Worksheets("Word_Files")
lastrow = Worksheets("Word_Files").UsedRange.Rows.Count + 1
totTbl = objDoc.Tables.Count
Debug.Print totTbl
For Each oTbl In objDoc.Tables
strCellText = oTbl.cell(1, 1).Range.Text
strCellText = LCase(strCellText)
Debug.Print strCellText
If strCellText Like "*data input*" Then
Worksheets("Word_Files").Range("A" & lastrow) = strFolder & strFile
On Error Resume Next
If cnt = 1 Then
lastrow = lastrow
Else
lastrow = ActiveSheet.UsedRange.Rows.Count
End If
oTbl.Range.Copy
Range("B" & lastrow).Select
sht.Paste
cnt = cnt + 1
End If
Next oTbl
End If
filecounter = filecounter + 1
Debug.Print filecounter
objWord.Close
Next cell
objDoc.Quit
Set objDoc = Nothing
objWord.Quit
Set objWord = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
SecondsFinal = SecondsElapsed / 60
MsgBox ("Code ran in " & SecondsFinal & "minutes.")
End Sub
I want to export data from selected Outlook emails to a workbook. Each email's data (subject, body, etc.) should be stored in a different worksheet.
I'm trying to edit this macro because it is almost what I need—and especially the part of olFormatHTML and WordEditor—because of split.
The idea is
Select multiple emails in Outlook
Open file path
Data for each email selected will be stored in a single worksheet from file opened
The issue with the macro is in this third part
From the selected items, the macro does a loop and just takes the first email selected,
The data is stored in different workbooks; it should be stored in the same workbook that I opened.
Public Sub SplitEmail()
Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
'----------------------------------------------
Set itm = GetCurrentItem() 'A)I think the issuefrom selecting 1 item is located here
'|||||||||||||||||||||||||||||||||||||||||
sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"
If Not itm Is Nothing Then
Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If
Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text
'||||||||||||||||||||||||||||||||||||||||||||||
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile) 'B) tried to move it to the beginning and macro doesn't work
'||||||||||||||||||||||||||||||||||||||||||||||
For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i) 'B)emails in diferrent sheet but no same workbook
Next i
'------------------------------------------------------
Next x
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing
End Function
I made an update to this macro
as macro do loop in For x it open the file x times,
and then close it and open again instead of working on the first workbook opened
but the macro leaves open instances
here is the current code
Public Sub SplitEmail()
Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
'----------------------------------------------
Dim objApp As Outlook.Application
Dim GetCurrentItem As Object
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(x)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing
'-----------------------------------------------
Set itm = GetCurrentItem
sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"
If Not itm Is Nothing Then
'de lo contrario, se crea un Reply del correo en formato HTML
Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If
Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text
'||||||||||||||||||||||||||||||||||||||||||||||
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile)
xlApp.Windows("Macro.xlsm").Activate
'Set wb = ActiveWorkbook
'||||||||||||||||||||||||||||||||||||||||||||||
For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i)
Next i
xlApp.Windows("Macro.xlsm").Close SaveChanges:=True
xlApp.Workbook.Close SaveChanges:=False
'------------------------------------------------------
Next x
'------------------------------------------------------
'the instances should closed but not working, instances are empty
For Each wb In xlApp
wb.Close SaveChanges:=False
Next
End Sub
done, I added xlApp.Quit after saving files and deleted the last part For Each wb In xlApp...
I'm fairly new to programming. Could you, please, help me identify the problem and possibly solve it. The macro below is supposed to extract tables from an e-mail folder. The first two parts work pretty well: I can open up the Excel export file and choose the email folder. However, export to the file fails as a target spreadsheet appears not to be recognized as an object. Thank you in advance.
Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim i As Integer
Dim WordDoc, Selection, XL, Tabl, WL, WB As Object
'Open up an Excel file
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = XL.Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
'Choose the export folder
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
'Run through e-mails collecting tables
For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
Set Tabl = WordDoc.Tables(i)
Tabl.Range.Copy
'Insert*emphasized text* each table to a separate sheet
Set WL = WB.Sheets(i)
'Here is where the error 424 occurs: Object required
**WL.Range("a1").End(xlDown).Offset(1, 0).Select**
Selection.Parent.PasteSpecial Format:="Text", Link:=False, _
DisplayAsIcon:=False
Next i
Else: MsgBox "No tables found"
Exit Sub
End If
Next Mails
End Sub
Declare like this:
Dim WordDoc As Object
Dim Selection As Object
Dim XL As Object
Dim Tabl As Object
Dim WL As Worksheet
Dim WB As Workbook
Thus, you will make sure that they are objects indeed. In your code, only WB is object, the others are of type Variant.
Thanks to a colleague of mine, the issue has been resolved.
Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim XL As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim WL As Object
Dim WordDoc As Object
Dim Tabl As Object
Dim i As Integer
Dim Selection As Object
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
Dim lastRow As Integer
For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
Set Tabl = WordDoc.Tables(i)
Tabl.Range.Copy
Set WS = WB.Worksheets(i)
lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
WS.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
Next i
Else
MsgBox "No tables found"
GoTo LabelNext
End If
LabelNext:
Next Mails
End Sub
I will preface this by stating that I have no VBA knowledge, I can sort of read it but I certainly can't write it. I have also spent a good amount of time looking for previously answered questions that will provide me with a solution but have not found anything similar enough for me to adapt it with my limited knowledge.
What I am trying to do is write a VBA script that will read the subject of all emails in an Outlook folder, count predefined keywords and write the result to separate cells in an Excel spreadsheet. Additionally, read the body and copy an entire sentence that appears after a phrase to a cell in Excel.
These emails have a fixed format:
Subject: [keyword, three possibilities] [keyword, three possibilities] ["!" or "?" or nothing]
Body:
Search Engine: [text to copy, single word]
Keyword: [text to copy, a single sentence on one continuous line]
Below is code I believe to be relevant to what I'm trying to do but can't piece together into a single script. For reading a single, selected email in Outlook and writing the subject to separate Excel cells based on a pre-defined pattern:
Option Explicit
Private Const xlUp As Long = -4162
Sub CopyToExcel()
Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3 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
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Tally.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")
Set olItem = Application.ActiveExplorer().Selection()
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = olItem.Subject
Set Reg1 = CreateObject("VBScript.RegExp")
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "((\w*)\s*(\w*)\s*(\w*))"
End With
If Reg1.test(sText) Then
' each "(\w*)" and the "(\d)" are assigned a vText variable
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
vText2 = Trim(M.SubMatches(2))
vText3 = Trim(M.SubMatches(3))
Next
End If
xlSheet.Range("B" & rCount) = vText
xlSheet.Range("c" & rCount) = vText2
xlSheet.Range("d" & rCount) = vText3
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
A script that takes the date of an email and tallies the number of time it occurs:
Const olFolderInbox = 6
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set colItems = objFolder.Items
For Each objItem in colItems
strDate = FormatDateTime(objItem.SentOn, vbShortDate)
If objDictionary.Exists(strOnline) Then
objDictionary.Item(strOnline) = objDictionary.Item(strOnline) + 1
Else
objDictionary.Add strOnline, "1"
End If
Next
colKeys = objDictionary.Keys
For Each strKey in colKeys
Wscript.Echo strKey, objDictionary.Item(strKey)
Next
And a simple If statement, if the subject has this, then do this(?):
Dim strSubject As String
strSubject = Item.Subject
If strSubject Like "*example1*" or strSubject Like "*example2*" Then
Any help with this would be much appreciated as this is not my area of expertise.
You've got most of the pieces here, yes. But you'll have some difficulty. This is what I can whip up in a few minutes and without testing. SOme of this code appears to be written in Excel (the first code), whereas the second function you have looks like native Outlook VBA.
Either function can (relatively easily) be ported to the other application (which I've tried to do, assuming it's preferable to run this code from Excel VBA as a generally easier-to-work-with interface), but I make no guarnatees :)
Here's the general idea, and rough code:
Use your second script, the one which loops over all emails, as the main script.
Call the first script from within the loop, modifying it as needed with the logic you need and also to avoid re-opening the file every time.
Note: I am using late-binding on the Outlook objects so that this function can hopefully be called from Excel VBA without requiring reference to the outlook library. Also this code is not tested so make sure all variables are properly declared and typed.
Option Explicit
Sub Main()
Dim colItems as Object
Dim objItem as Object
Dim objOutlook as Object 'Outlook.Application
Dim objNamespace as Object
Dim objFolder as Object 'Outlook.Folder
Dim objDictionary as Object 'Scripting.Dictionary
Dim strSubject As String
Const olFolderInbox = 6
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set colItems = objFolder.Items
For Each objItem in colItems
'## Get the subject
strSubject = objItem.Subject
'## Check for the conditions:
If strSubject Like "*example1*" or strSubject Like "*example2*" Then
Call WriteToExcel(objOutlook, objItem, "C:\path\to\your\file.xlsx") '## MODIFY FILE PATH!
End If
Next
Next
End Sub
Sub WriteToExcel(objItem As Object, $strPath)
Dim olItem As Object 'Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim sText As String
Dim rCount As Long
Dim txt as String
Set xlApp = Application 'Assumes you're running this from EXCEL
'Check if the workbook already open
For each xlWB = xlApp.Workbooks
If xlWB.FullName = strPath Then Exit For
Next
If xlWB Is Nothing Then Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
sText = objItem.Subject
'## Prints the subject in Column B
xlSheet.Range("B" & rCount) = sText
'##### HERE IS WHERE YOU NEED TO COUNT YOUR KEYWORDS####
'#######################################################
'#######################################################
'#######################################################
txt = olItm.Body
'## Omitting lines that close Excel app & Workbook, etc.
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
I'm creating code wherein Outlook will extract all emails to an existing Excel file.
The code works and extracts all emails from a selected folder. However, when I try to use the same code on a separate folder, let's say Sent Items, it doesn't extract the data and opens a Read only version of the Excel file.
I plan to leave Outlook and Excel Open.
How can I work with any Outlook folder and still update the Excel file?
Private Sub Application_NewMailv7()
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim objOL As Outlook.Application
Dim objItems As Outlook.Items
Dim myItem As MailItem
Dim myXLApp As Excel.Application
Dim myXLWB As Excel.Workbook
Dim StrBody As String
Dim TotalRows As Long, i As Long
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
Set myXLApp = New Excel.Application
myXLApp.Visible = True
Set myXLWB = myXLApp.Workbooks.Open("C:\Users\username\Desktop\Folder Name\SR Historyv2.xlsx")
Set excWks = myXLWB.Worksheets("Sheet1")
TotalRows = Sheets(1).Range("A65536").End(xlUp).Row
i = TotalRows + 1
For Each obj In objItems
If obj.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(i, 1) = Format(obj.ReceivedTime, "mm/dd/yyyy")
excWks.Cells(i, 2) = obj.SenderEmailAddress
excWks.Cells(i, 3) = obj.Subject
i = i + 1
'myXLWB.Save
End If
Next
Set obj = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing
End Sub
Try the following and if you would like to run Outlook Rule, let me know I will update the answer
Option Explicit
Sub Excel()
Dim xlApp As Object 'Excel App
Dim xlWB As Object 'WorkBook
Dim xlSheet As Object
Dim rngCount As Long
Dim xlStarted As Boolean
Dim xlPath As String
Dim olExplorer As Explorer
Dim olSelection As Selection
Dim olItem As Outlook.MailItem
Dim olMsg As Object
Dim xlColA, xlColB, xlColC, xlColD As String
'// Path of the Workbook - update only -> "\Folder Name\Folder Name\Book1.xlsx"
xlPath = Environ("USERPROFILE") & _
"\Documents\Temp\Book1.xlsx"
'// Set up Excel Application
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")
xlStarted = True
End If
On Error GoTo 0
'// Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(xlPath)
Set xlSheet = xlWB.Sheets("Sheet1") ' or use (1) or (Sheet Name)
'// Record msg
On Error Resume Next
'// Find the next empty line of the worksheet
rngCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'// Get the values from Outlook
Set olExplorer = Application.ActiveExplorer
'// Select Outlook msg
Set olSelection = olExplorer.Selection
For Each olMsg In olSelection
Set olItem = olMsg
'// Info to collect
xlColA = olItem.ReceivedTime
xlColB = olItem.SenderName
xlColC = olItem.SenderEmailAddress
xlColD = olItem.To
'// Write it to Excel sheet
xlSheet.Range("A" & rngCount) = xlColA
xlSheet.Range("B" & rngCount) = xlColB
xlSheet.Range("C" & rngCount) = xlColC
xlSheet.Range("D" & rngCount) = xlColD
'// Go to Next row
rngCount = rngCount + 1
Next
'// Save & Close Excel.Application
xlWB.Close 1
If xlStarted Then
xlApp.Quit
End If
'// Clean up
Set olItem = Nothing
Set olMsg = Nothing
Set olExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Do you close the SR Historyv2 workbook after you run the script or do you want to keep it open the entire time? If you keep it open and run the script again it will open the workbook a second time and that will be read only. For the second question i would suggest you look into the ItemAdd event in Outlook. This will only work if Outlook is open. https://msdn.microsoft.com/en-us/library/office/aa171270(v=office.11).aspx
I got this code working properly
Set myXLApp = GetObject(, "Excel.Application")
'specify the History File
With myXLApp
.Workbooks("SR Historyv2.xlsx").Activate
End With
It keeps the file to open and lets the other macro access it without being read-only.