CDO is much quicker for iterating through large collections, but you'd have
to rewrite most of your code. You could also use the Import/Export Wizard to
export Contacts to a .csv file to import into Excel, but you wouldn't be able
to export custom fields.

--
Eric Legault (Outlook MVP, MCDBA, MCTS: Messaging & Collaboration)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/


"Tinz" wrote:

Speeding up code.

After a lot of trial-and-error coding and tons of support from you lot I
have now got a working (sort of) code that exports a desired subset of
contacts from outlook to excel in a useable fassion.

Some of the custom field names weren’t liked for some reason and I have had
to go through and re-name them, such as OrgMainBody and IsLiveNow – any
reason why?

And also, some contacts it just dosent like – for example it kept stopping
on one contact – ‘Goods I R’ – for some reason, so I have had to rename them??

My main question now is – how can I make this faster? When I run it , it
takes a few seconds to open the excel sheet, then it slowly writes the
details cell-by-cell, for example I timed it using a filter of 300 items from
a folder of 2000, extracting 10 fields from each item, it took 5 ½ mins. I
know its not glacial but the old program I used to use for this would export
all information from the contact cards and do it in less than a minute.

Could I, for example, filter out the contacts earlier in the code and then
loop through the results – would that make a difference? Is there a quicker
way of getting the data written into Excel?

Any speed-up tips would be welcomed

The code (abbreviated):

Sub FilterToExcel()

Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim i
Dim intTotalCount
Dim intDoneCount
Dim objApp
Dim objFolder
Dim objItems
Dim objItem
Dim strFilter

intTotalCount = 0
intDoneCount = 0
i = 2

Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Workbooks.Add
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True

'Get Current Contacts folder

Set objApp = CreateObject("Outlook.Application")
Set objFolder = objApp.ActiveExplorer.CurrentFolder

intTotalCount = objFolder.Items.Count
On Error Resume Next

objExcelSheet.Range("A" & 1).Value = "Company Name"
objExcelSheet.Range("B" & 1).Value = "Mailing Address"
objExcelSheet.Range("E" & 1).Value = "Year End"
objExcelSheet.Range("G" & 1).Value = "CO2"
…
objExcelSheet.Range("L" & 1).Value = "Company/Contact"
objExcelSheet.Range("S" & 1).Value = "EmmisHigh"

strFilter = "[FilingCategoryName] = " & Chr(34) & "EE" & Chr(34)

For Each objItem In objFolder.Items.Restrict(strFilter)

i = i + 1

strRange = "A" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.CompanyName "" Then objRange.Value = objItem.CompanyName

…

strRange = "L" & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
If objItem.MessageClass "IPM.Contact.mod.company" Then
objRange.Value = "Company"
If objItem.MessageClass "IPM.Contact.mod.contact" Then
objRange.Value = "Contact"

intDoneCount = intDoneCount + 1

Next

‘objExcelSheet.Cells.Select.EntireRow.AutoFit
‘objExcelSheet.Cells.Select.EntireColumn.AutoFit
‘Not working? Selects cells but nothing else?

MsgBox intDoneCount & " of " & intTotalCount & " contacts exported."
End Sub

===============
ascii silly question, get a silly ansi