Update excel sheet based on outlook mail [closed] - excel

It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 11 years ago.
My objective is to update an excel sheet, whenever I am getting mails with a particular subject (I set up a rule for moving relevant mails to a folder).
I saw a similar post in this site, but the code given is not complete. Being not a 'pro' or 'techie' its very difficult to wrtie codes.
Mail contains:
File Name:
Owner Name:
Last update date:
File locaion(this will be share drive path):
I will get this mail daily and need to update this info in an excel sheet. (which i will keep open till the month end)
Please help me. Thanks in advance

Introduction
In the first version of this answer, I referred you to another question which I now know you will not be able to read.
All the code you need is here but this is not written as an immediate solution. This is a tutorial which introduces you to the Outlook object model, getting data out of the outlook database and into an Excel workbook. Don't worry that you are not "a 'pro' or 'techie'"; once we were all newbies. Work through the sections. Don't worry if you don't understand it all. Just pick out the bits you need now. When you want to enhance your solution, come back to this tutorial and the code which you will have copied to your disc.
In the following sections, AnswerA() and AnswerB() are intended to help you understand the folder structure. AnswerC1() is also a short term training aid. However, AnswerC2() and AnswerC3() are subroutines that you may need permenently. If you do keep them, I suggest you rename them; for example: FindFolder() and FindFolderSub().
AnswerD() is also a training aid but one you should retain. This shows you how to access a few mail item properties but I you may need access to more mail item properties than I have shown. Within the VB Editor, click F2 to display the Object Explorer. Scroll down the list of classes to MailItem. You will be shown a list of over 100 methods and properties. Some are obvious but you will have to use VB Help to discover the purpose of many. Expand AnswerD() to use methods or display properties you think might be useful.
AnswerE() is a development aid but also provides the structure for your macro. Currently it outputs to disc the text and html bodies of the mail items within a folder. You do not want to do this at the moment but you might. I archive all my emails to Excel. I create one row per email with columns for sender, recipients, subject, dates, etc. I save the text body, html body and any attachments to disc and create hyperlinks to them. I have emails going back years from multiple Outlook installations.
AnswerF1() shows you how to create a new Excel workbook and AnswerF2() shows you how to open an existing Excel workbook. I assume AnswerF2() is what you need.
There is a lot here but if you work through it steadily you will come to understand the Outlook object model and how to achieve your objective.
Health warning
Everything in this answer was discovered by experimentation. I started with VB Help, used F2 to access the object model and experimented until I found what worked. I did buy a highly recommended reference book but it contained nothing important I had not discovered and omitted much that I had discovered.
I suspect that a key feature of the knowledge I have gained is that it is based on many different installations. Some of the problems encountered may have been the result of installation mistakes which would explain why reference book authors did not know of them.
The code below has been tested with Excel 2003 and Outlook Exchange 2003 and 2007.
Getting started if you are unfamiliar with Outlook VBA
Open "Outlook" or "Outlook Exchange". These macros do not work with "Outlook Express".
From the toolbar, select Tools, Macro, Security. Change the security level to "Medium" if it is not already at that level. This means that macros can be run but only with your explicit approval.
To start the Outlook VB Editor either:
1) From the toolbar, select Tools, Macro, Macros
or click Alt+F11
2) Select Enable macros.
From the tool bar, select Insert, Module.
You can see one, two or three windows. Down the left should be the Project Explorer. You do not need it today but, if it is missing, click Ctrl+R to display it. To the right, at the top, is the area into which you will place the code. At the bottom you should see the Immediate Window. If the Immediate Window is missing, click Ctrl+G to display it. The macros below all use the Immediate Window for output so you must be able to see it.
The cursor will be in the code area.
Enter: Option Explicit.
This instructs the VB Editor to check that all variables are defined. The code below have been tested but this avoids one type of error in any code you may enter.
One by one, copy and paste the macros below into the code area.
Macros AnswerC(), AnswerD(), Answer(E), AnswerF1() and AnswerF2() will require some modification before running. Instructions within the macro.
To run a macro, place the cursor within it and press F5.
Accessing the top two folder levels
The top level of folders are of type Folders. All subfolders are of type MAPIFolder. I have never tried accessing the top level other than as a means of getting to the subfolders.
AnswerA() gets access to the Outlook Exchange database and outputs the names of the top level folders to the Immediate Window.
Sub AnswerA()
Dim InxIFLCrnt As Integer
Dim TopLvlFolderList As Folders
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxIFLCrnt = 1 To TopLvlFolderList.Count
Debug.Print TopLvlFolderList(InxIFLCrnt).Name
Next
End Sub
AnswerB() outputs the names of the top level folders and their immediate children.
Sub AnswerB()
Dim InxIFLCrnt As Integer
Dim InxISLCrnt As Integer
Dim SndLvlFolderList As MAPIFolder
Dim TopLvlFolderList As Folders
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxIFLCrnt = 1 To TopLvlFolderList.Count
Debug.Print TopLvlFolderList(InxIFLCrnt).Name
Set SndLvlFolderList = TopLvlFolderList.Item(InxIFLCrnt)
For InxISLCrnt = 1 To SndLvlFolderList.Folders.Count
Debug.Print " " & SndLvlFolderList.Folders(InxISLCrnt).Name
Next
Next
End Sub
The problem with AnswerB() is that the children can have children can have children to any depth. You need to be able to find a particular folder whatever the depth.
Find named folder
If you want to search a default folder such as "Inbox" or "Sent Items" you will not need this code. If you copy the messages containing tables to a different folder you will need this code. Even if you decide you do not need this code now, I suggest you keep it in case you need it in the future.
The code below uses two sub-routines. The caller assembles a folder name such as "Personal Folders|MailBox|Inbox". The sub-routines work down the hierarchy and return the required folder as an object if it is found.
Note: the special case of locating a default folder such as "Inbox" or "Sent Items" is discussed later.
Sub AnswerC1()
' This routine wants a folder. It does nothing but display its name.
Dim FolderNameTgt As String
Dim FolderTgt As MAPIFolder
' The names of each folder down to the one required separated
' by a character not used in folder names.
' ##############################################################
' Replace "Personal Folders|MailBox|Inbox" with the name
' of one of your folders. If you use "|" in your folder names,
' pick a different separator and change the call of AnswerC2().
' ##############################################################
FolderNameTgt = "Personal Folders|MailBox|Inbox"
Call AnswerC2(FolderTgt, FolderNameTgt, "|")
If FolderTgt Is Nothing Then
Debug.Print FolderNameTgt & " not found"
Else
Debug.Print FolderNameTgt & " found: " & FolderTgt.Name
End If
End Sub
Sub AnswerC2(ByRef FolderTgt As MAPIFolder, NameTgt As String, NameSep As String)
' This routine initialises the search and finds the top level folder
Dim InxFolderCrnt As Integer
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Integer
Dim TopLvlFolderList As Folders
Set FolderTgt = Nothing ' Target folder not found
Set TopLvlFolderList = _
CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
' I need at least a level 2 name
Exit Sub
End If
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To TopLvlFolderList.Count
If NameCrnt = TopLvlFolderList(InxFolderCrnt).Name Then
' Have found current name. Call AnswerC3() to look for its children
Call AnswerC3(TopLvlFolderList.Item(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
Exit For
End If
Next
End Sub
Sub AnswerC3(FolderCrnt As MAPIFolder, ByRef FolderTgt As MAPIFolder, _
NameTgt As String, NameSep As String)
' This routine finds all folders below the top level
Dim InxFolderCrnt As Integer
Dim NameChild As String
Dim NameCrnt As String
Dim Pos As Integer
' Split NameTgt into the name of folder at current level
' and the name of its children
Pos = InStr(NameTgt, NameSep)
If Pos = 0 Then
NameCrnt = NameTgt
NameChild = ""
Else
NameCrnt = Mid(NameTgt, 1, Pos - 1)
NameChild = Mid(NameTgt, Pos + 1)
End If
' Look for current name. Drop through and return nothing if name not found.
For InxFolderCrnt = 1 To FolderCrnt.Folders.Count
If NameCrnt = FolderCrnt.Folders(InxFolderCrnt).Name Then
' Have found current name.
If NameChild = "" Then
' Have found target folder
Set FolderTgt = FolderCrnt.Folders(InxFolderCrnt)
Else
'Recurse to look for children
Call AnswerC3(FolderCrnt.Folders(InxFolderCrnt), _
FolderTgt, NameChild, NameSep)
End If
Exit For
End If
Next
End Sub
Examining a target folder
AnswerC2() and AnswerC3() provides the code to find a target folder. Folders contain items: mail items, meeting requests, contacts, calendar entries and more. Only mail items are examined by this code. Accessing meeting requests is essentially the same but they have different properties.
AnswerD() outputs a selection of a mail item's properties.
Once you have tried AnswerD() on a selection of folders, press F2 or, from the tool bar, select View, Object Browser. Scroll down the list of items until you reach MailItem. The members' area will display all its properties and methods of which there are in excess of 100. Some are pretty obvious; most you will have to look up in VB Help. Amend this routine to explore more properties and methods and, perhaps, other types of item.
Warning. This code is designed to look through a named folder for mail items. You may encounter problems if you amend the code to explore the entire folder hierarchy. It could have been my mistake or it could have been faults in the installation but I have found that my code crashes if I attempt to access certain folders such as "RSS Feeds". I have never been interested enough to explore these crashes and have simply amended my tree search to ignore branches with selected names.
When you run this macro, you will receive a warning: "A program is trying to access e-mail addresses you have stored in Outlook. Do you want to allow this?" Tick "Allow access for", select an interval, and click Yes.
Sub AnswerD()
Dim FolderItem As Object
Dim FolderItemClass As Integer
Dim FolderNameTgt As String
Dim FolderTgt As MAPIFolder
Dim InxAttach As Integer
Dim InxItemCrnt As Integer
' ##############################################################
' Replace "Personal Folders|MailBox|Inbox" with the name
' of one of your folders. If you use "|" in your folder names,
' pick a different separator and change the call of AnswerC2().
' ##############################################################
FolderNameTgt = "Personal Folders|MailBox|Inbox"
Call AnswerC2(FolderTgt, FolderNameTgt, "|")
If FolderTgt Is Nothing Then
Debug.Print FolderNameTgt & " not found"
Else
' Display mail items, if any, within folder
Debug.Print "Mail items within " & FolderNameTgt
For InxItemCrnt = 1 To FolderTgt.Items.Count
Set FolderItem = FolderTgt.Items.Item(InxItemCrnt)
With FolderItem
' This code seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = .Class
On Error GoTo 0
If FolderItemClass = olMail Then
' Display Received date, Attachment count and Subject
Debug.Print " Mail item: " & InxItemCrnt
Debug.Print " Received=" & Format(.ReceivedTime, _
"ddmmmyy hh:mm:ss") & " " & _
.Attachments.Count & _
" attachments Subject = " & .Subject
Debug.Print " Sender: " & .SenderName
With .Attachments
' If the are attachments display their types and names
If .Count > 0 Then
Debug.Print " Attachments:"
For InxAttach = 1 To .Count
With .Item(InxAttach)
Debug.Print " Type=";
Select Case .Type
Case olByReference
Debug.Print "ByRef";
Case olByValue
Debug.Print "ByVal";
Case olEmbeddeditem
Debug.Print "Embed";
Case olOLE
Debug.Print " OLE";
End Select
Debug.Print " DisplayName=" & .DisplayName
End With
Next
End If
End With
End If
End With
Next InxItemCrnt
End If
End Sub
Saving bodies to disc
AnswerE() finds a folder of your choice and saves a copy of the text and html bodies of every mail item within it. I suggest you copy a select of messages containing table to a new folder and run AnswerE(). This is not directly relevant to your questions but I believe it will aid understanding.
When you run this macro, you will receive a warning: "A program is trying to access e-mail addresses you have stored in Outlook. Do you want to allow this?" Tick "Allow access for", select an interval, and click Yes.
Sub AnswerE()
' Output any Text or HTML bodies found within specified folder
Dim FolderItem As Object
Dim FolderItemClass As Integer
Dim FolderNameTgt As String
Dim FolderTgt As MAPIFolder
Dim FileSystem As Object
Dim FileSystemFile As Object
Dim HTMLBody As String
Dim InxAttach As Integer
Dim InxItemCrnt As Integer
Dim PathName As String
Dim TextBody As String
' ##############################################################
' Replace "Personal Folders|MailBox|Inbox" with the name
' of one of your folders. If you use "|" in your folder names,
' pick a different separator and change the call of AnswerC2().
' The folder you pick must have at least one mail item with an
' HTML body for this macro to do anything.
' ##############################################################
FolderNameTgt = "Personal Folders|MailBox|Inbox"
Call AnswerC2(FolderTgt, FolderNameTgt, "|")
If FolderTgt Is Nothing Then
Debug.Print FolderNameTgt & " not found"
Exit Sub
End If
' ####################################################################
' The following is an alternative method of accessing a default folder
' such as Inbox. This statement would replace the code above.
' Set FolderTgt = CreateObject("Outlook.Application"). _
' GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' ####################################################################
' Extract bodies if found
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' ##############################################################
' Replace "C:\Email\" with the name of one of your folders
' ##############################################################
PathName = "C:\Email\"
For InxItemCrnt = 1 To FolderTgt.Items.Count
Set FolderItem = FolderTgt.Items.Item(InxItemCrnt)
With FolderItem
' This code seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = .Class
On Error GoTo 0
If FolderItemClass = olMail Then
HTMLBody = Trim(.HTMLBody)
If HTMLBody <> "" Then
' Save HTML body to disc. The file name is of the form
' BodyNNN.html where NNN is a a sequence number.
' First True in CreateTextFile => overwrite existing file.
' Second True => Unicode format
Set FileSystemFile = FileSystem.CreateTextFile(PathName & _
"Body" & Right("00" & InxItemCrnt, 3) & _
".html", True, True)
FileSystemFile.Write HTMLBody
FileSystemFile.Close
End If
TextBody = Trim(.Body)
If HTMLBody <> "" Then
' Save text body to disc. The file name is of the form
' BodyNNN.txt where NNN is a a sequence number.
Set FileSystemFile = FileSystem.CreateTextFile(PathName & _
"Body" & Right("00" & InxItemCrnt, 3) & _
".txt", True, True)
FileSystemFile.Write TextBody
FileSystemFile.Close
End If
End If
End With
Next InxItemCrnt
End Sub
Creating or updating an Excel workbook
You do not say if you will create a new Excel workbook or update an existing one. AnswerF1() creates a workbook. AnswerF2() opens an existing workbook.
Before trying either of these macros you must:
From within the Outlook VBA Editor, select Tools from the toolbar.
Select References.
Scroll down to Microsoft Excel 11.0 Object Library and tick the box against it.
.
Sub AnswerF1()
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim PathName As String
' ##############################################################
' Replace "C:\Email\" with the name of one of your folders
' Replace "MyWorkbook.xls" with the your name for the workbook
' ##############################################################
PathName = "C:\Email\"
FileName = "MyWorkbook.xls"
Set xlApp = Application.CreateObject("Excel.Application")
With xlApp
.Visible = True ' This slows your macro but helps during debugging
Set ExcelWkBk = xlApp.Workbooks.Add
With ExcelWkBk
' Add Excel VBA code to update workbook here
.SaveAs FileName:=PathName & FileName
.Close
End With
.Quit
End With
End Sub
Sub AnswerF2()
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim PathName As String
' ##############################################################
' Replace "C:\Email\" with the name of one of your folders
' Replace "MyWorkbook.xls" with the your name for the workbook
' ##############################################################
PathName = "C:\Email\"
FileName = "MyWorkbook.xls"
Set xlApp = Application.CreateObject("Excel.Application")
With xlApp
.Visible = True ' This slows your macro but helps during debugging
Set ExcelWkBk = xlApp.Workbooks.Open(PathName & FileName)
With ExcelWkBk
' Add Excel VBA code to update workbook here
.Save
.Close
End With
End With
End Sub
Writing to the Excel workbook
This code finds the next free row in you workbook and writes to it. I explain why constants are useful and warn you about keeping your Outlook and Excel code apart.
' Constants allow you alter the sequence of columns in your workbook without
' having to change your code. Replace the 1, 2 and 3 in these statements
' and the job is done.
' !!! Constants must be above any subroutines and functions.
Public Const ColFrom As Integer = 1
Public Const ColSubject As Integer = 2
Public Const ColSentDate As Integer = 3
Sub AnswerG()
Dim RowNext As Integer
' This code goes at the top of your macro
With Sheets("Sheet1") ' Replace with the name of your worksheet
' This finds the bottom row with a value in column A. It then adds 1 to get
' the number of the first unused row.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
' You will have to separate your Outlook and Excel code.
' With Outlook
' Var1 = .Body
' Var2 = .ReceivedTime
' Var3 = .SenderName
' End With
' With Excel
' .Cell(R, C).Value = Var1
' End With
With Sheets("Sheet1") ' Replace with the name of your worksheet
.Cells(RowNext, ColFrom).Value = "John Smith"
.Cells(RowNext, ColSubject).Value = "Our meeting"
With .Cells(RowNext, ColSentDate)
.Value = Now()
' This format means the time is stored and I can access it but it
'is not displayed. Change to "mm/dd/yy" or whatever you like.
.NumberFormat = "d mmm yy"
End With
RowNext = RowNext + 1 ' Ready for next loop
End With
End Sub
Summary
I hope I have provided an appropriate level of detail. Please respond with a comment either way.
Don't leap to the final macros. If anything goes wrong you will not understand the cause. Take the time to play with each of the earlier answers. Amend them to do something slightly different.
Best of luck. You will be amazed how quickly you will become comfortable with Outlook and VBA.

Related

VBA Excel -- Workbook.ChangeLink is not responding

For a side-gig I need to replace a the prefix of all data links in a TB worth of excel files from an old drive to a new drive (ex: from \\foo\rest_of_path\ to \\bar\rest_of_path\).
Before running it on the bulk, I'm running it on 25 or so files (one of the many subfolders)
My Macro currently creates a list of all subdirectories in the rootdirectory given to the macro and runs the code below on all found .xlsx files.
I get no compilation errors and no runtime errors.
However, the macro keeps hanging and not responding on the very first data link that it tries to change.
Any ideas why ?
Code:
Sub ChangeFileLinks(ByVal documentPath As String)
' Define variables
Dim excelFile As Workbook
Dim fileLinks As Variant
Dim item As Variant
Dim sourceName As String
Dim newSourceFile As String
' Remove variable value in case the file was not properly closed
Set excelFile = Nothing
' Open Workbook with password that is definitely not good to redirect to Error handler
' if the workbook is password protected.
Set excelFile = Application.Workbooks.Open( _
fileName:=document, _
IgnoreReadOnlyREcommended:=True, _
UpdateLinks:=False, _
Password:="MyFakePassword")
On Error GoTo 0
' If the file has been opened create Array of data sources
If Not excelFile Is Nothing Then
excelFile.Activate ' Activating the file seems to improve performance
fileLinks = ActiveWorkbook.LinkSources
' If there are data sources in the file iterate through the array
If Not IsEmpty(fileLinks) Then
For Each item In fileLinks
sourceName = item
' If current data source starts with the oldPathRoot - modify the PathRoot
If StartsWith.StartsWith(sourceName, Globals.OLD_PATH_ROOT) = True Then
' append the newPathRoot to the the file name
newSourceFile = Replace(sourceName, Globals.OLD_PATH_ROOT, Globals.NEW_PATH_ROOT)
' change data source
ActiveWorkbook.ChangeLink item, newSourceFile
Globals.SOURCE_LINKS_MODIFIED = Globals.SOURCE_LINKS_MODIFIED + 1
Else
Globals.SOURCE_LINKS_UNTOUCHED = Globals.SOURCE_LINKS_UNTOUCHED + 1
End If
Next item
End If
' Close Workbook
excelFile.Close SaveChanges:=True
Else
Debug.Print document
Debug.Print "--> PASSWORD PROTECTED !"
End If
End Sub

Save Outlook Attachment to Folder on PC using Excel VBA

I am trying to save attachments from a sub-folder in Outlook to a folder on my C drive using Excel VBA.
For example, in my inbox folder I have a sub-folder called 'data' and in this folder there are emails with different excel attachments of different data but with the same formatting and the same attachment name but with an updated date (Eg: "Attachment name + 28 March").
These emails are sent daily. I want all attachments, not already saved, saved to a folder on my C drive and then open each attachment to extract the relevant data to Excel.
I am able to extract the relevant data once the files are in my C drive but I am unable to set up a path from my Excel to Outlook without Outlook VBA (which I don't want to do).
This is what I have so far: (the comments are for my benefit because I am new to this)
Sub attachmentsave()
Dim olook As Outlook.Application
Dim omailitem As Outlook.mailitem
'whenever dealing with folders we need to define outlook.namespace This is a class that opens the gate for me to access all outlook folders
Dim onamespace As Outlook.Namespace
Dim fol As Outlook.Folder 'we need to tell vba where we have out emails with attachments stored
Dim atmt As Outlook.Attachment '.attachment is a class that will help us deal with emails that have attachments
Set olook = New Outlook.Application
Set omailitem = olook.CreateItem(olmailitem)
'messaging application protocol interface
Set onamespace = olook.GetNameSpace("MAPI")
Set fol = onamespace.GetDefaultFolder(olFolderInbox)
For Each omailitem In fol.items
For Each atmt In omailitem.attachments
atmt.SaveAsFile "C:/" & atmt.FileName
'all attachments in inbox should be save in C drive
Next
Next
End Sub
You need a macro-enabled Excel workbook with a reference to "Microsoft Output nn.n Object Library" where “nn.n” depends on the version of Office you are running. Please do not mix versions; I have never tried but I understand it causes problems.
I am assuming you are familiar with Excel VBA and know how to create a macro-enabled workbook. From your comments, I assume you do not know about references.
Much of the power of VBA is not native but comes from libraries which you can reference if you need their functionality. Open the VBA Editor and click Tools and then References. You will get a long list of available references. Those at the top will be ticked. For example, "Microsoft Excel nn.n Object Library" will be ticked. Without this reference, the compiler would not know what a range or a worksheet was. Note: "nn.n" depends on the version of Office you are using. For me, the value is "16.0" because I am using Office 365.
Unticked references are in alphabetic sequence. Scroll down the list until you find "Microsoft Outlook nn.n Object Library". Click the box to the left to tick this reference. Click "OK". If you click Tools then References again you will see "Microsoft Outlook nn.n Object Library" ticked and near the top. The compiler now has access to the definitions of MailItem, Folder and the rest of the Outlook Object Model.
Copy the code below to a new module:
Option Explicit
Sub ListStores()
' Needs reference to "Microsoft Output nn.n Object Library"
' where "nn.n" depends on the version of Outlook you are using.
Dim AppOut As New Outlook.Application
Dim InxStoreCrnt As Long
Dim FldrInbox As Outlook.Folder
With AppOut
With .Session
Debug.Print "List of stores:"
For InxStoreCrnt = 1 To .Folders.Count
Debug.Print " " & .Folders(InxStoreCrnt).Name
Next
Set FldrInbox = .GetDefaultFolder(olFolderInbox)
Debug.Print "Store for default Inbox: " & FldrInbox.Parent.Name
End With
End With
AppOut.Quit
Set AppOut = Nothing
End Sub
VBA usually has more than one method of achieving a desired effect. You have used “NameSpace” in your code whilst I have used “Session”. The documentation says these two methods are equivalent. If you write your own code, you can pick whichever method you prefer. But if you go looking for useful snippets, you must be ready for other people having different preferences.
Dim AppOut As New Outlook.Application creates an instance of Outlook that will access Outlook’s files on behalf of the macro.
With AppOut
With .Session
: : : :
End With
End With
I can replace : : : : with any Outlook VBA. If an Excel macro tries to access an email, the user will be warned and asked to give permission for the macro to run.
Outlook keeps emails, appointments, tasks and so on in files it calls Stores. You may see these called PST files because most have an extension of PST but an OST file is also a store. You may see them called Accounts because, by default, Outlook creates one store per email account. However, you can create as many extra stores as you want, none of which will be Accounts.
This code will create a list of the stores you can access:
Debug.Print "List of stores:"
For InxStoreCrnt = 1 To .Folders.Count
Debug.Print " " & .Folders(InxStoreCrnt).Name
Next
The output might look something like:
List of stores:
Outlook Data File
Smith John#ISPOne.com
Archive Folders
Backup
John Smith#ISPTwo.com
OutlookOutlook
The above is based on my home installation. A work installation is likely to be somewhat different. The differences will depend on the options chosen during installation. A work installation is also likely to included shared folders which I do not have on my system.
If you look at your folder pane, you will have names with other names indented underneath. The names be will the stores and will match the stores listed by the macro although the sequence will probably be different. The other names in the folder pane will be the folders within each store.
The last bit of my macro is:
Set FldrInbox = .GetDefaultFolder(olFolderInbox)
Debug.Print "Store for default Inbox: " & FldrInbox.Parent.Name
You have similar code to access an Inbox but this may not be the Inbox you want. On my system, this code outputs:
Store for default Inbox: Outlook Data File
“Outlook Data File” is Outlook’s default store. On my system, the calendar and my tasks are held in this store but my emails are not. I have two email accounts and each has their own store.
Try this above macro. Does GetDefaultFolderfind the Inbox you need to access?
Now add this macro:
Sub ListStoresAndFirstEmails()
' Needs reference to "Microsoft Output nn.n Object Library"
' where "nn.n" depends on the version of Outlook you are using.
Dim AppOut As New Outlook.Application
Dim InxFldrCrnt As Long
Dim InxStoreCrnt As Long
Dim FldrInbox As Outlook.Folder
With AppOut
With .Session
Debug.Print "List of stores and first emails:"
For InxStoreCrnt = 1 To .Folders.Count
Debug.Print " " & .Folders(InxStoreCrnt).Name
For InxFldrCrnt = 1 To .Folders(InxStoreCrnt).Folders.Count
If .Folders(InxStoreCrnt).Folders(InxFldrCrnt).Name = "Inbox" Then
Set FldrInbox = .Folders(InxStoreCrnt).Folders(InxFldrCrnt)
If FldrInbox.Items.Count > 0 Then
With FldrInbox.Items(1)
Debug.Print " Subject: " & .Subject
Debug.Print " Received: " & .ReceivedTime
Debug.Print " From: " & .SenderEmailAddress
End With
End If
Exit For
End If
Next
Next
End With
End With
AppOut.Quit
Set AppOut = Nothing
End Sub
This macro is also about investigating your stores. The macro scans down your stores. For each store, it scans down the list of level 1 folders looking for "Inbox". If it finds "Inbox", it assumes the oldest item in it is a MailItem and outputs its subject, received time and sender. If the oldest item is not a MailItem, you will get an error. I almost hope you do get an error to demonstrate the importance of not making assumptions.
Finally add:
Sub ListAttachments()
Dim AppOut As New Outlook.Application
Dim InxAttachCrnt As Long
Dim InxItemCrnt As Long
Dim InxStoreCrnt As Long
Dim FldrData As Outlook.Folder
With AppOut
With .Session
Set FldrData = .Folders("Outlook Data File").Folders("Inbox").Folders("Data")
End With
End With
Debug.Print "List emails with attachments within: ";
Debug.Print " " & FldrData.Name & " of " & FldrData.Parent.Name & _
" of " & FldrData.Parent.Parent.Name
With FldrData
For InxItemCrnt = 1 To FldrData.Items.Count
If .Items(InxItemCrnt).Class = olMail Then
With .Items(InxItemCrnt)
If .Attachments.Count > 0 Then
Debug.Print " Subject: " & .Subject
Debug.Print " Received: " & .ReceivedTime
Debug.Print " From: " & .SenderEmailAddress
For InxAttachCrnt = 1 To .Attachments.Count
Debug.Print " " & InxAttachCrnt & " " & .Attachments(InxAttachCrnt).DisplayName
Next
End If
End With
End If
Next
End With
AppOut.Quit
Set AppOut = Nothing
End Sub
I always keep some junk emails in store "Outlook Data File" for testing purposes.
In Set FldrData = .Folders("Outlook Data File").Folders("Inbox").Folders("Data") you need to replace "Outlook Data File" with the name of the store containing the emails of interest. If I understand correctly, the emails are in folder "Data" under folder "Inbox". If I have misunderstood, notice how I have used a chain of "Folders(xxxx)" to reach the required folder. In earlier emails I have used indices to reach stores and folders. Here I have specified a specific folder.
Within that folder I look for MailItems (showing how to avoid other items) and if they have attachments, list some properties of the email and the names of its attachments.
This is as far as I can go because I do not fully understand your explanation of how attachments are named or where you want attachments saved.

Copying base data sheet along with selected sheets from source workbook to new workbook

I am looking at building a master workbook which receives a monthly dump of data for all Cost Centres which will then populate a large number of worksheets within the workbook, and which then need to be split off and sent out to service heads. A service head will receive a selection of worksheets based on the first 4 characters of the sheet name (although this may change in due course).
eg 1234x, 1234y, 5678a, 5678b will produce two new workbooks named 1234 and 5678 with two sheets in each.
I have cobbled some code from various forum to create a macro that will work through a hard coded array defining the service head 4 character codes and create a series of new workbooks. And which seems to work.
However.. I also need to include the main data dump sheet within the source file (called "data") with the the array of files being copied over so that the links remain with the data sheet being copied over. If I write a line to copy over the data sheet separately, the new workbook still refers back to the source file, which service heads do not have access to.
So main question is: how can I add the "data" tab into the Sheets(CopyNames).Copy code so it is copied over with all the other files in the array at the same to keep the links intact?
Second question is if I decide it is the first two characters of the worksheet define the sheets that relate to a service head, how do I tweak the split/mid line of code - I've trialled around but am getting tied up in knots!
Any other tips to make the code more elegant much appreciated (there may be quite a long list of service head codes and I am sure there is a better way of creating a list for the routine to loop through)
Sub Copy_Sheets()
Dim strNames As String, strWSName As String
Dim arrNames, CopyNames
Dim wbAct As Workbook
Dim i As Long
Dim arrlist As Object
Set arrlist = CreateObject("system.collections.arraylist")
arrlist.Add "1234"
arrlist.Add "5678"
Set wbAct = ActiveWorkbook
For Each Item In arrlist
For i = 1 To Sheets.Count
strNames = strNames & "," & Sheets(i).Name
Next i
arrNames = Split(Mid(strNames, 2), ",")
'strWSName =("1234")
strWSName = Item
Application.ScreenUpdating = False
CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
If UBound(CopyNames) > -1 Then
Sheets(CopyNames).Copy
ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
ActiveWorkbook.Close
wbAct.Activate
Else
MsgBox "No sheets found: " & strWSName
End If
Next Item
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub CopySheets()
With ThisWorkbook
Dim SheetIndex As Long
Dim ValidSheetNames() As String
ReDim ValidSheetNames(1 To .Worksheets.Count)
' Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. '
Dim ws As Worksheet
For Each ws In .Worksheets
If ws.Name <> "DEDICATEDSHEET" Then
SheetIndex = SheetIndex + 1
ValidSheetNames(SheetIndex) = ws.Name
End If
Next ws
ReDim Preserve ValidSheetNames(1 To SheetIndex)
' Read all ServiceCodes into a 1-dimensional array '
Dim ServiceHeadCodes As Variant
ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)
Dim CodeIndex As Long
' Now loop through each ServiceHeadCode '
For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)
' Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy '
Dim SheetsToCopy() As String
SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)
' Check if SheetToCopy now contains any sheet names at all. '
If UBound(SheetsToCopy) > -1 Then
' Add the name of the Data sheet to the end of the array '
ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
SheetsToCopy(UBound(SheetsToCopy)) = "Data"
Dim OutputWorkbook As Workbook
Set OutputWorkbook = Application.Workbooks.Add
' Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook '
.Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)
' Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. '
' But suppress the Are you sure you want to delete this sheet.. message. '
Application.DisplayAlerts = False
OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
' Re-enable alerts, as we want to see any other dialogue boxes/messages
' Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved.'
OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
OutputWorkbook.Close
Else
MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
End If
Next CodeIndex
End With
End Sub
Untested and written on mobile, sorry for bad formatting.
This approach proposes that you store all service head codes in a 1-column Excel table on a dedicated sheet that is referred to via Excel table nomenclature (which might be easier than ArrayList.Add for each new service head code).
I assume code is stored in master workbook ('thisworkbook'), which might not be true.
You could modify the serviceheadcodes table directly on the spreadsheet itself, if you later decide that SheetsToCopy will be determined by first 2, 3 or X characters -- or you could modify array itself with left$() function.
Hope it works or gives you some ideas.
Edit: This is my sheet and table layout (which I assume matches yours).
And this is what the code above gives me on my computer.

Automate creation of charts in multiple excel files?

I just spent a significant amount of time creating identical graphs in several dozen excel files (all containing identically formatted data,) and believe there has to be a more efficient way of completing what I've just done.
To simplify things, consider 50 excel documents with data in the same format. Does there exist a method of automatically:
Creating a simple line graph
Adding axis labels, a chart label, removing horizontal grid lines
Including a trend line/R^2 value
Saving the new workbook to a certain location with "_graphed" appended to the filename
Would this be something that an Excel VBA could be used for?
For this sort of problem I would start by recording a macro of the steps you take manually into a personal macro workbook. You can then look at the code produced by Excel and you may find that you don't need to make too many changes for this to be useful as a generic procedure.
After testing, if you wanted to take the automation one step further you could write a little procedure to loop through all of the Excel files in a directory and call your chart procedure for each file when it is open. I can dig out come code I wrote doing something similar if it will help.
Update
Here is a thread where I have provided some code to loop through all of the files containing some given text (in this example ".pdf" but could just as easily be ".xls" to cover xlsx, xlsm etc).
Also this example prints out a list of the files it finds to a worksheet. This is a good start to test the results, but once this is okay you would need to replace the line:
Range(c).Offset(j, 0).Value = vFileList(i)
With some code to open that workbook and call your code to generate the chart. Let me know if you get stuck.
Further Update
I have reviewed the code referred to above and made a few improvements including an additional parameter for you to specify the name of a macro that you want to run against each of the workbooks opened (that meet the condition specified). The macro that you use in the call must exist in the workbook that you are calling all of the other workbooks from (e.g. if the chart macro is in your personal workbook then the code below should also be placed in your personal macro workbook):
Option Explicit
Sub FileLoop(pDirPath As String, _
Optional pPrintToSheet = False, _
Optional pStartCellAddr = "$A$1", _
Optional pCheckCondition = False, _
Optional pFileNameContains = "xxx", _
Optional pProcToRunOnWb)
On Error GoTo PrintFileList_err
' Local constants / variables
Const cProcName = "FileLoop"
Dim vFileList() As String ' array for file names
Dim i As Integer ' iterator for file name array
Dim j As Integer ' match counter
Dim c As String
' variables for optional param pProcToRunOnWb
Dim vFullPath As String
Dim vTmpPath As String
Dim wb As Workbook
vFullPath = Application.ThisWorkbook.FullName
vFileList = GetFileList(pDirPath)
c = pStartCellAddr
j = 0
For i = LBound(vFileList) To UBound(vFileList)
' if condition is met (i.e. filename cotains text or condition is not required...
If pCheckCondition And InStr(1, vFileList(i), pFileNameContains, vbTextCompare) > 0 _
Or Not pCheckCondition Then
' print name to sheet if required...
If pPrintToSheet Then
Range(c).Offset(j, 0).Value = vFileList(i)
j = j + 1 ' increment row offset
End If
' open wb to run macro if required...
If pProcToRunOnWb <> "" Then
Application.DisplayAlerts = False ' set alerts off so that macro can run in other wb
vTmpPath = pDirPath & "\" & vFileList(i)
Set wb = Workbooks.Open(Filename:=vTmpPath)
Workbooks(wb.Name).Activate
Application.Run "'" & vFullPath & "'!" & pProcToRunOnWb
wb.Close (True) ' save and close workbook
Application.DisplayAlerts = True ' set alerts back on
End If
End If
Debug.Print vFileList(i)
Next i
' clean up
Set wb = Nothing
PrintFileList_exit:
Exit Sub
PrintFileList_err:
Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
vbCrLf, "Err Description: ", Err.Description
Resume Next
End Sub
Function GetFileList(pDirPath As String) As Variant
On Error GoTo GetFileList_err
' Local constants / variables
Const cProcName = "GetFileList"
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim c As Double ' upper bound for file name array
Dim i As Double ' iterator for file name array
Dim vFileList() As String ' array for file names
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(pDirPath)
c = objFolder.Files.Count
i = 0
ReDim vFileList(1 To c) ' set bounds on file array now we know count
'Loop through the Files collection
For Each objFile In objFolder.Files
'Debug.Print objFile.Name
i = i + 1
vFileList(i) = objFile.Name
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
GetFileList = vFileList
GetFileList_exit:
Exit Function
GetFileList_err:
Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
vbCrLf, "Err Description: ", Err.Description
Resume Next
End Function
You can call this from another macro or from the immediate window (ctrl+G) with the parameters required e.g. to get all files containing '.xls', and run a macro named 'your_macro_name_here' the code would be:
call FileLoop("C:\Users\Prosserc\Dropbox\Docs\Stack_Overflow\Test", False, "", True, ".xls", "your_macro_name_here")
Obviously change the path in the first parameter to point to the directory containing the files that you want to run the macro against.
There is a library called Xlsxwriter for both python and perl which allows for the automation of chart generation. For some sample python code, see my post here.

deleted names in a Wbk still exist and refer to locations that don't exist, slow Excel

In VBA Help for the RefersTo Property, they give this example of listing all the Names in a Wkb (fleshed out so you can run it as is)
Sub showNames()'from VBA Help for "RefersTo"
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add
Dim i As Long, nm As Name
i = 1
For Each nm In ActiveWorkbook.Names
newSheet.Cells(i, 1).Value = nm.Name
newSheet.Cells(i, 2).Value = "'" & nm.RefersTo
i = i + 1
Next
newSheet.Columns("A:B").AutoFit
End Sub
When I run that on my current project, it turns up many Names that I thought were long gone. But here they are still hanging around and referring to places that no longer exist. I think this is what's slowing up my system and I'd love to get rid of those Names, but they don't show up in the Define Name window so where do I find them?
edit: Meant to mention that the Links item is greyed out for this Wbk.
Update
option 1
A manual method to delete corrupt names using R1C1 (I can recall JKP stating on another forum he had code to do this but he wasn't prepared to provide it for free)
Select Tools, Options and click the General tab.
Click the check box next to "R1C1 Reference Style", so that you change the current setting.
Press OK.
Excel will prompt you to change the name of any name (in all open workbooks!) that contains illegal characters.
Select Insert, name, define to delete the newly renamed names.
Set the R1C1 Reference style back the way you prefer using Tools, Options, General.
option 2
Chris Neilsen posted this at Any chance to delete programatically corrupt ranged names (with spaces) in Excel (2007/2010)
But, here's a possible alternative: SaveAs your workbook as a .xlsm
You should get a dialog complaining about invalid names, with a option
to rename and a Ok to All button. Once saved, close and reopen the
file, Save As an .xls and you should be good to go
Initial Post
Download Name Manager which is the stand out addin by Jan Karel Pieterse and Charles Williams for managing names
It will handle Names that
now error out as the ranges have been deleted (your issue),
link to other Workbooks,
are now corrupt
Plus it will convert global names to local sheet names, and vice versa and so on
- Updated Answer -
Since you know the names of the invalid ranges but can't see them in the Name Manager, you can try to delete them manually from the VBA Immediate window. The name you gave GrPix!patternListRange indicates a worksheet name so you should be able to delete it by typing
ActiveWorkbook.Names("GrPix!patternListRange").Delete
or
Sheets("GrPix").Names("patternListRange").Delete
in the Immediate Window
Original Answer
Have you tried deleting the invalid names via code? i.e.
For Each nm In ActiveWorkbook.Names
If InStr(nm.RefersTo, "OldFileName.xls") > 0 Then
nm.Delete
End If
Next nm
Here are two more solutions that may work for others searching on this topic, but these still don't fix my own particular Workbook.
I'm still looking.
This is from Aaron Blood and shows the R1C1 method mentioned by brettdj:
Sub RemoveDemonLinks()
Dim wbBook As Workbook
Dim nName As Name
Dim i As Long
Set wbBook = ActiveWorkbook
i = 0
If wbBook.Names.Count > 0 Then
With Application
.ReferenceStyle = xlR1C1
.ReferenceStyle = xlA1
End With
For Each nName In wbBook.Name
If InStr(nName.RefersTo, "#REF!") > 0 Then nName.Delete
i = i + 1
Next nName
If i > 0 Then MsgBox i & " corrupted names was deleted from " & wbBook.Name
End If
End Sub
This is from MS Help
' Module to remove all hidden names on active workbook
Sub Remove_Hidden_Names()
' Dimension variables.
Dim xName As Variant
Dim Result As Variant
Dim Vis As Variant
' Loop once for each name in the workbook.
For Each xName In ActiveWorkbook.Names
'If a name is not visible (it is hidden)...
If xName.Visible = True Then
Vis = "Visible"
Else
Vis = "Hidden"
End If
' ...ask whether or not to delete the name.
Result = MsgBox(prompt:="Delete " & Vis & " Name " & _
Chr(10) & xName.Name & "?" & Chr(10) & _
"Which refers to: " & Chr(10) & xName.RefersTo, _
Buttons:=vbYesNo)
' If the result is true, then delete the name.
If Result = vbYes Then xName.Delete
' Loop to the next name.
Next xName
End Sub

Resources