[Solved] I have a question regarding mail merge. I have to email multiple records associated with a single email address, how to do it?

Hello hassan99663

Thank you for contacting us. I understand you want to email multiple records associated with a single email address. You can implement a VBA code to obtain the required result. I have taken your provided dataset in a sheet named “Sheet1”. You may need to change the sheet name in provided VBA code based on your worksheet name.

Insert the following code in a module of Visual Basic Editor and press F5 to execute it.
Code:
Sub sendRecordsViaEmail()
    
    Dim outlook As Object
    Dim newEmail As Object
    Dim xInspect As Object
    Dim pageEditor As Object
    
    Dim lastRow As Integer
    Dim arr() As Variant
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    Dim sIndex As Integer
    Dim eIndex As Integer
    
    lastRow = Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row
    count = 0
    
    Set Rng = Range("B2:G" & lastRow)
    ReDim arr(1 To 1)
    
    For i = 2 To Rng.Rows.count
        If Rng.Cells(i, Rng.Columns.count).Value <> "" Then
            count = count + 1
            ReDim Preserve arr(1 To count)
            arr(count) = i
        End If
    Next i
    
    For i = LBound(arr) To UBound(arr)
        
        Dim shn As String
        shn = Rng.Cells(arr(i), 1).Value
        Sheets.Add.Name = shn
        Sheets("Sheet1").Range("B2:F2").Copy Sheets(shn).Cells(2, 2)
        
        sIndex = arr(i) + 1
            
        If i = UBound(arr) Then
            eIndex = lastRow
        Else
            eIndex = arr(i + 1)
        End If
        
        Sheets("Sheet1").Range("B" & sIndex & ":F" & eIndex).Copy Sheets(shn).Cells(3, 2)
        
        Sheets(shn).Cells.EntireColumn.AutoFit
        
        Dim nsLastRow As Integer
        nsLastRow = Sheets(shn).Cells(Rows.count, 2).End(xlUp).Row
        
        Set outlook = CreateObject("Outlook.Application")
        Set newEmail = outlook.CreateItem(0)

        With newEmail
            .To = Rng.Cells(arr(i), Rng.Columns.count)
            .CC = ""
            .BCC = ""
            .Subject = "Debit Data"
            .Body = "Please find the requested information" & vbCrLf & "Best Regards"
            .display
            
            Set xInspect = newEmail.GetInspector
            Set pageEditor = xInspect.WordEditor
            
            Sheets(shn).Range("B2:F" & nsLastRow).Copy
            pageEditor.Application.Selection.Start = Len(.Body)
            pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
            pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
            .display
            .send
            Set pageEditor = Nothing
            Set xInspect = Nothing
        End With
        
        'Delete this segment if you require the grouped data in a different sheet
        Application.DisplayAlerts = False
        Sheets(shn).Delete
        Application.DisplayAlerts = True
        
    Next i
    
End Sub
I hope this will be sufficient for your requirements. Let us know your feedback.

Regards,
Seemanto Saha
ExcelDemy
 

Attachments

  • 2.png
    2.png
    218.4 KB · Views: 5
Hello hassan99663

Thank you for contacting us. I understand you want to email multiple records associated with a single email address. You can implement a VBA code to obtain the required result. I have taken your provided dataset in a sheet named “Sheet1”. You may need to change the sheet name in provided VBA code based on your worksheet name.

Insert the following code in a module of Visual Basic Editor and press F5 to execute it.
Code:
Sub sendRecordsViaEmail()
   
    Dim outlook As Object
    Dim newEmail As Object
    Dim xInspect As Object
    Dim pageEditor As Object
   
    Dim lastRow As Integer
    Dim arr() As Variant
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    Dim sIndex As Integer
    Dim eIndex As Integer
   
    lastRow = Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row
    count = 0
   
    Set Rng = Range("B2:G" & lastRow)
    ReDim arr(1 To 1)
   
    For i = 2 To Rng.Rows.count
        If Rng.Cells(i, Rng.Columns.count).Value <> "" Then
            count = count + 1
            ReDim Preserve arr(1 To count)
            arr(count) = i
        End If
    Next i
   
    For i = LBound(arr) To UBound(arr)
       
        Dim shn As String
        shn = Rng.Cells(arr(i), 1).Value
        Sheets.Add.Name = shn
        Sheets("Sheet1").Range("B2:F2").Copy Sheets(shn).Cells(2, 2)
       
        sIndex = arr(i) + 1
           
        If i = UBound(arr) Then
            eIndex = lastRow
        Else
            eIndex = arr(i + 1)
        End If
       
        Sheets("Sheet1").Range("B" & sIndex & ":F" & eIndex).Copy Sheets(shn).Cells(3, 2)
       
        Sheets(shn).Cells.EntireColumn.AutoFit
       
        Dim nsLastRow As Integer
        nsLastRow = Sheets(shn).Cells(Rows.count, 2).End(xlUp).Row
       
        Set outlook = CreateObject("Outlook.Application")
        Set newEmail = outlook.CreateItem(0)

        With newEmail
            .To = Rng.Cells(arr(i), Rng.Columns.count)
            .CC = ""
            .BCC = ""
            .Subject = "Debit Data"
            .Body = "Please find the requested information" & vbCrLf & "Best Regards"
            .display
           
            Set xInspect = newEmail.GetInspector
            Set pageEditor = xInspect.WordEditor
           
            Sheets(shn).Range("B2:F" & nsLastRow).Copy
            pageEditor.Application.Selection.Start = Len(.Body)
            pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
            pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
            .display
            .send
            Set pageEditor = Nothing
            Set xInspect = Nothing
        End With
       
        'Delete this segment if you require the grouped data in a different sheet
        Application.DisplayAlerts = False
        Sheets(shn).Delete
        Application.DisplayAlerts = True
       
    Next i
   
End Sub
I hope this will be sufficient for your requirements. Let us know your feedback.

Regards,
Seemanto Saha
ExcelDemy
Sir thank you for the support but it is not working as desire. The code is emailing whole sheet in a email.
I am attaching screenshot of the output and sending you excel file as well.
 

Attachments

  • Mail Merge.xlsx
    10.2 KB · Views: 2
  • Error.png
    Error.png
    68.8 KB · Views: 3
Hello hassan99663,
Sorry for the inconvenience. The error occurred due to my dataset starting from Cell B2. I have modified the code according to your dataset now.

Code:
Sub sendRecordsViaEmail()
    
    Dim outlook As Object
    Dim newEmail As Object
    Dim xInspect As Object
    Dim pageEditor As Object
    
    Dim lastRow As Integer
    Dim arr() As Variant
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    Dim sIndex As Integer
    Dim eIndex As Integer
    
    lastRow = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
    count = 0
    
    Set Rng = Range("A1:F" & lastRow)
    ReDim arr(1 To 1)
    
    For i = 2 To Rng.Rows.count
        If Rng.Cells(i, Rng.Columns.count).Value <> "" Then
            count = count + 1
            ReDim Preserve arr(1 To count)
            arr(count) = i
        End If
    Next i
    
    For i = LBound(arr) To UBound(arr)
        
        Dim shn As String
        shn = Rng.Cells(arr(i), 1).Value
        Sheets.Add.Name = shn
        Sheets("Sheet1").Range("A1:E1").Copy Sheets(shn).Cells(2, 2)
        
        sIndex = arr(i)
            
        If i = UBound(arr) Then
            eIndex = lastRow
        Else
            eIndex = arr(i + 1) - 1
        End If
        
        Sheets("Sheet1").Range("A" & sIndex & ":E" & eIndex).Copy Sheets(shn).Cells(3, 2)
        
        Sheets(shn).Cells.EntireColumn.AutoFit
        
        Dim nsLastRow As Integer
        nsLastRow = Sheets(shn).Cells(Rows.count, 2).End(xlUp).Row
        
        Set outlook = CreateObject("Outlook.Application")
        Set newEmail = outlook.CreateItem(0)

        With newEmail
            .To = Rng.Cells(arr(i), Rng.Columns.count)
            .CC = ""
            .BCC = ""
            .Subject = "Debit Data"
            .Body = "Please find the requested information" & vbCrLf & "Best Regards"
            .display
            
            Set xInspect = newEmail.GetInspector
            Set pageEditor = xInspect.WordEditor
            
            Sheets(shn).Range("B2:F" & nsLastRow).Copy
            pageEditor.Application.Selection.Start = Len(.Body)
            pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
            pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
            .display
            .send
            Set pageEditor = Nothing
            Set xInspect = Nothing
        End With
        
        'Delete this segment if you require the grouped data in a different sheet
        Application.DisplayAlerts = False
        Sheets(shn).Delete
        Application.DisplayAlerts = True
        
    Next i
    
End Sub
The Excel file is also attached here. Let us know your feedback.

Regards,
Seemanto Saha
ExceldDemy
 

Attachments

  • Mail Merge.xlsm
    19.6 KB · Views: 0

Online statistics

Members online
0
Guests online
15
Total visitors
15

Forum statistics

Threads
278
Messages
1,198
Members
473
Latest member
tu2815
Top