Another optimized approach; -instead of reading each cell read from
memory!

<aircode
Sub AddContacts_Outlook2()
Dim appOL As Object, wsSrc As Worksheet, vNamespace, vFolder, vItem,
vData
Dim lLastRow&, n& 'Type Long

If bOutlookAvailable Then
If gbOutlookIsRunning Then
Set appOL = GetObject(, "Outlook.Application")
Else
Set appOL = CreateObject("Outlook.Application")
End If 'gbOutlookIsRunning
Else
MsgBox "This process requires MS Outlook be installed", vbCritical
Exit Sub
End If 'bOutlookAvailable

Set wsSrc = Sheets("Sheet1") '//assumes ActiveWorkbook
lLastRow = wsSrc.Cells(wksSrc.Rows.Count, 1).End(xlUp).Row

On Error GoTo Cleanup
With appOL
Const DeletedItems& = .OlDefaultFolders.olFolderDeletedItems '3
Const ContactItem& = .OlItemType.olContactItem '2
Const SaveItem& = .OlInspectorItem.olSave '0

Set vNamespace = .GetNamespace("MAPI")
Set vFolder = vNamespace.GetDefaultFolder(DeletedItems)
'Empty vFolder
For n = vFolder.Items.Count To 1 Step -1: vItems(n).Delete: Next 'n

'Post each row's data
Set vItem = .CreateItem(ContactItem)
vData = Range(Cells(2, 1), Cells(lLastRow, 10))
With vItem
.Display
For n = LBound(vData) To UBound(vData)
.FirstName = vData(n, 1): .LastName = vData(n, 2)

.CompanyName = vData(n, 5): .JobTitle = vData(n, 3)
.BusinessTelephoneNumber = vData(n, 7)

.EmailAddress = vData(n, 4): .HomeAddress = vData(n, 9)
.HomeTelephoneNumber = vData(n, 6)
.MobileTelephoneNumber = vData(n, 8)

.Body = vData(n, 10): .Save
Next 'n
.Close
End With 'vItem
End With 'appOL

Cleanup:
'Close Outlook if wasn't running
If Not gbOutlookIsRunning Then appOL.Quit
Set appOL = Nothing: Set wsSrc = Nothing
Set vNamespace = Nothing, Set vFolder = Nothing, Set vItem = Nothing

End Sub 'AddContacts_Outlook

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion