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