Directory Mail Merge and then email using Outlook

Hi All,

I am new to this forum. I couldn't find specific to Outlook group so posting here.

I am looking for some help in creating a directory mail merge. I have data in spreadsheet in the following format.

I have created a directory mail merge in which I have got one letter for each publisher consisting of books list I need to order. i.e. One letter to PubA with all three titles. My letter varies with publisher according to number of books.

The problem I am facing is how to email these letters to just one email Id using outlook.

For example, I want to send my directory mail merge to Publisher PubA just once on his email abc@test.com and not three times as shown in my excel spreadsheet.

I have tried merging with new documents and emailing but it mails all 5 letters together to all the emails present in the spreadsheet.

I want individual letters to specific recipients only.

I hope I have explained my problem. Any feedback or help would be highly appreciated. Thanks in advance.

-Aroma

Hi there:

I would suggest to run the macro listed below on your worksheet (make sure to set topCell to the cell the first occurrence of PubA is located in (I assumed it might be A2). I have uploaded a workbook that contains both your original sample and the aggregated version: http://www.eggheadcafe.com/fileupload/629396994_BookListAggregation.zip (please note that although the file extension is .zip this is actually an Excel workbook; you'll need to rename it to *.xls before you open it).

Please don't hesitate to contact me if you have any further questions.

Good luck,
Rolf Jaeger
SoarentComputing
http://soarentcomputing.com
510.300.7462

Sub AggregateBooks()
    Dim topCell As Range
    Dim iRow As Integer
    Dim nBooks As Integer
    
    Set topCell = Range("A2")
    
    iRow = 0
    Do
        nBooks = 0
        Do
            topCell.Offset(iRow + nBooks, 0).Select
            If topCell.Offset(iRow + nBooks + 1, 0).Value <> topCell.Offset(iRow + nBooks, 0).Value Then Exit Do
            topCell.Offset(iRow, 1).Value = topCell.Offset(iRow, 1).Value & Chr(10) & topCell.Offset(iRow + nBooks + 1, 1)
            nBooks = nBooks + 1
        Loop
        iRow = iRow + 1
        If nBooks > 0 Then
            Rows(iRow + 1 & ":" & iRow + nBooks).Select
            Selection.Delete
        End If
        If topCell.Offset(iRow, 0).Value = "" Then Exit Do
    Loop
End Sub