Const olContactItem = 2

 Sub DeleteContacts()
 Dim myOutlook As Outlook.Application
 Dim myInformation As NameSpace
 Dim myContacts As Items
 Dim i As Long
 Dim lngCount As Long
 Set myOutlook = CreateObject("Outlook.Application")
 Set myInformation = myOutlook.GetNamespace("MAPI")
 Set myContacts = myInformation.GetDefaultFolder(olFolderContacts).Items
 lngCount = myContacts.Count
 For i = lngCount To 1 Step -1
 myContacts(i).Delete
 Next
 End Sub

 Sub Perenos_Kontaktov_iz_Excel()
 Dim objXls As Object
 Dim i As Single, j As Single
 Dim myNameSpace As NameSpace
 Dim myFolder As MAPIFolder, myWorkFolder As MAPIFolder
 Dim myOutlook As Outlook.Application
 Dim myItems As ContactItem
 Set objXls = CreateObject("Excel.Application")
 objXls.Workbooks.Open "C:\Data.xls"
 'укажите путь и имя существующего файла
 objXls.Application.Visible = False
 Set myOutlook = CreateObject("Outlook.Application")
 j = objXls.ActiveSheet.UsedRange.Rows.Count
    For i = 1 To j
    Set myItems = myOutlook.CreateItem(olContactItem)
        With myItems
    .FullName = objXls.ActiveSheet.Range("A" & i).Value & " " & _
                objXls.ActiveSheet.Range("B" & i).Value & " " & _
                objXls.ActiveSheet.Range("C" & i).Value
    .Birthday = objXls.ActiveSheet.Range("D" & i).Value
    .Email1Address = objXls.ActiveSheet.Range("E" & i).Value
    .Save
End With
    Next i
 Set objXls = Nothing
 Set myOutlook = Nothing
End Sub

Dim objXls
 Dim i, j 
 Dim myNameSpace 
 Dim myFolder, myWorkFolder
 Dim myOutlook
 Dim myItems
 Set objXls = CreateObject("Excel.Application")
 objXls.Workbooks.Open "C:\Data.xls"
 'укажите путь и имя существующего файла
 objXls.Application.Visible = False
 Set myOutlook = CreateObject("Outlook.Application")
 j = objXls.ActiveSheet.UsedRange.Rows.Count
    For i = 1 To j
    Set myItems = myOutlook.CreateItem(olContactItem)
        With myItems
    .FirstName = objXls.ActiveSheet.Range("A" & i).Value
    .LastName = objXls.ActiveSheet.Range("B" & i).Value
    .Birthday = objXls.ActiveSheet.Range("D" & i).Value
    .Email1Address = objXls.ActiveSheet.Range("E" & i).Value
    .Save
End With
    Next
 Set objXls = Nothing
 Set myOutlook = Nothing