I got it to work by simple changing the code to :



Option Explicit

Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long

Application.ScreenUpdating = False

'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.PickFolder

If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)

'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Utility"
.Cells(1, 2).Value = "City, State"
.Cells(1, 3).Value = "Main Contact"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact person"
.Cells(1, 6).Value = "E-mail"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With

Set olColItems = olFolder.Items

'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) 0 Then
Cells(i, 1).Value = .UserProperties("Utility")
Cells(i, 2).Value = .UserProperties("CityState")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address

Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If


Next olItem


With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With

Application.ScreenUpdating = True

MsgBox "The list has successfully been updated!", vbInformation

ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub





However now I get the following message when I run the code:
"a program is trying to access e-mail addresses you have stored in
outlook. do you want to allow this"

And I have to click yes for every single contact in my address book.
Can I stop this error message from appearing?