T
Tinz
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
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