Перенос контактов в Outlook из Excel

Создавать контакты в Microsoft Outlook можно на основе данных, сохраненных в Excel-файлах. Одним из способов является импорт данных стандартными средствами Outlook, заслуживающий отдельного внимания. Сейчас же речь пойдет о макросе VBA, осуществляющего обмен данными между Excel и  Outlook.

Если возникла необходимость создать контакты для Outlook на основе базы данных с именами, фамилиями, адресами электронной почты и др., сохраненных или экспортированных в файлы приложения Excel, то сделать это можно программным способом, автоматизировав процесс создания контактов при помощи макроса написанного на языке Visual Basic for Application, встроенного в приложения Microsoft Office.

Ранее уже рассматривался макрос для Outlook, запускающий Excel и макрос для Outlook, создающий контакт. Для автоматического создания контактов в Outlook на основе данных Excel-файлов, объединим эти макросы в один и в результате получим макрос для Outlook, который будет брать контактные данные в указанном файле из заданных ячеек и программно создавать контакты в Microsoft Outlook. Теперь, при наличии xls-файла, в столбцах A, B и C которого содержится информация об именах, фамилиях и адресах электронной почты соответственно, можно создать контакты в Outlook на основе этих данных. Разумеется, кроме этих контактных данных можно добавлять и множество других, если сопоставить поля в окне "Контакт" со свойствами объекта "Контакт" в VBA.

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:\DataBase.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
            .Email1Address = objXls.ActiveSheet.Range("C" & i).Value
            .Save
        End With
    Next i
 Set objXls = Nothing
 Set myOutlook = Nothing
End Sub

Для того, чтобы перенести этот программный код на свой компьютер, наведите курсор мыши на поле с программным кодом, нажмите на одну из двух кнопкок  в правом верхнем углу этого поля, скопируйте программный код и вставьте его в модуль проекта на своем компьютере (подробнее о том, как сохранить программный код макроса).