Sub CreateContactGroupfromExcel()
Dim objContactsFolder As Outlook.Folder
Dim objContact As Outlook.ContactItem
Dim objContactGroup As Outlook.DistListItem
Dim objExcelApp As New Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim nLastRow As Integer
Dim nCurrentRow As Integer
Dim objNameCell As Excel.Range
Dim objEmailCell As Excel.Range
Dim strName As String
Dim strEmail As String
Dim objTempMail As Outlook.MailItem
Dim objRecipients As Outlook.Recipients
Set objContactsFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Set objContactGroup = Outlook.Application.CreateItem(olDistributionListItem)
'You can change the contact group name
objContactGroup.DLName = "Group Name"
Set objExcelApp = CreateObject("Excel.Application")
'You should change the path to your own Excel file
Set objExcelWorkbook = objExcelApp.Workbooks.Open("E:\Contacts.xlsx")
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelWorksheet.Activate
nLastRow = objExcelWorksheet.UsedRange.Rows.Count
'The "A2" varies with the first contact's name cell in your own Excel file
Set objNameCell = objExcelApp.Range("A2")
objNameCell.Select
While nCurrentRow <= nLastRow
nCurrentRow = objNameCell.Row
strName = objNameCell.Value
If strName = "" Then
GoTo NextRow
End If
Set objEmailCell = objExcelApp.ActiveCell.Offset(0, 1)
strEmail = objEmailCell.Value
Set objContact = objContactsFolder.Items.Find("[FullName] = '" & strName & "'")
'If there is no such a contact, create it.
If objContact Is Nothing Then
Set objContact = Outlook.Application.CreateItem(olContactItem)
With objContact
.FullName = strName
.Email1Address = strEmail
.Save
End With
End If
'Add the contacts to the new contact group
Set objTempMail = Application.CreateItem(olMailItem)
objTempMail.Recipients.Add (strName)
Set objRecipients = objTempMail.Recipients
objContactGroup.AddMembers objRecipients
NextRow:
Set objNameCell = objExcelApp.ActiveCell.Offset(1, 0)
objNameCell.Select
Wend
'Use "objContactGroup.Save" to straightly save it
objContactGroup.Display
objTempMail.Close olDiscard
objExcelApp.Quit
End Sub
