Discussion Locked

Export Outlook Contacts to Excel without duplicates

0 helpful
0 replies
Closed to new repliesThis discussion is closed. It stays readable, but it takes no new replies.

Below is the macro I created to export the outlook contacts into cells in Excel. Now I need a macro to open that Excel file and export the contacts from Outlook into it without duplicating the ones that have already been imported to Excel. Please help.

Sub ExportToExcel()
On Error Resume Next

Const olFolderContacts = 10

Set objOutlook = CreateObject("Outlook.Application")

Set objNamespace = objOutlook.GetNamespace("MAPI")

Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items

Set ObjExcel = CreateObject("Excel.Application")

ObjExcel.Visible = True

Set objWorkbook = ObjExcel.Workbooks.Add()

Set objWorksheet = objWorkbook.Worksheets(1)

ObjExcel.Cells(1, 1) = "Name"
ObjExcel.Cells(1, 2) = "Ref NO"
ObjExcel.Cells(1, 3) = "Company"
ObjExcel.Cells(1, 4) = "EMail 1"
ObjExcel.Cells(1, 5) = "EMail 2"
ObjExcel.Cells(1, 6) = "EMail 3"
ObjExcel.Cells(1, 7) = "WebSite"
ObjExcel.Cells(1, 8) = "Tel #1"
ObjExcel.Cells(1, 9) = "Tel #2"
ObjExcel.Cells(1, 10) = "Cell"
ObjExcel.Cells(1, 11) = "Fax"
ObjExcel.Cells(1, 12) = "Address #1"
ObjExcel.Cells(1, 13) = "City #1"
ObjExcel.Cells(1, 14) = "State #1"
ObjExcel.Cells(1, 15) = "Zip #1"
ObjExcel.Cells(1, 16) = "Address #2"
ObjExcel.Cells(1, 17) = "City #2"
ObjExcel.Cells(1, 18) = "State #2"
ObjExcel.Cells(1, 19) = "Zip #2"
ObjExcel.Cells(1, 20) = "Well Name"
ObjExcel.Cells(1, 21) = "Orignator"
ObjExcel.Cells(1, 22) = "Operator"
ObjExcel.Cells(1, 23) = "Field"
ObjExcel.Cells(1, 24) = "Doc Type"
ObjExcel.Cells(1, 25) = "Lic #1"
ObjExcel.Cells(1, 26) = "S #1"
ObjExcel.Cells(1, 27) = "S #2"
ObjExcel.Cells(1, 28) = "P"

i = 2

For Each objContact In colContacts

ObjExcel.Cells(i, 1).Value = objContact.FullName
ObjExcel.Cells(i, 2).Value = objContact.JobTitle
ObjExcel.Cells(i, 3).Value = objContact.CompanyName
ObjExcel.Cells(i, 4).Value = objContact.Email1Address
ObjExcel.Cells(i, 5).Value = objContact.Email2Address
ObjExcel.Cells(i, 6).Value = objContact.Email3Address
ObjExcel.Cells(i, 7).Value = objContact.WebPage
ObjExcel.Cells(i, 8).Value = objContact.BusinessTelephoneNumber
ObjExcel.Cells(i, 9).Value = objContact.Business2TelephoneNumber
ObjExcel.Cells(i, 10).Value = objContact.MobilTelephoneNumber
ObjExcel.Cells(i, 11).Value = objContact.BusinessFaxNumber
ObjExcel.Cells(i, 12).Value = objContact.BusinessAddress
ObjExcel.Cells(i, 13).Value = objContact.BusinessAddressCity
ObjExcel.Cells(i, 14).Value = objContact.BusinessAddressState
ObjExcel.Cells(i, 15).Value = objContact.BusinessAddressPostalCode
ObjExcel.Cells(i, 16).Value = objContact.HomeAddress
ObjExcel.Cells(i, 17).Value = objContact.HomeAddressCity
ObjExcel.Cells(i, 18).Value = objContact.HomeAddressState
ObjExcel.Cells(i, 19).Value = objContact.HomeAddressPostalCode
ObjExcel.Cells(i, 20).Value = objContact.ManagerName
ObjExcel.Cells(i, 21).Value = objContact.ReferredBy
ObjExcel.Cells(i, 22).Value = objContact.User1
ObjExcel.Cells(i, 23).Value = objContact.OfficeLocation
ObjExcel.Cells(i, 24).Value = objContact.SchedulePlusPriority
ObjExcel.Cells(i, 25).Value = objContact.User2
ObjExcel.Cells(i, 26).Value = objContact.User3
ObjExcel.Cells(i, 27).Value = objContact.User4
ObjExcel.Cells(i, 28).Value = objContact.Sensitivity
i = i + 1

Next

Set objRange = objWorksheet.UsedRange

objRange.EntireColumn.AutoFit
End Sub

0 replies

No replies were posted before this discussion closed.

This discussion is closed to new replies.