[Solved] I have a question regarding mail merge. I have to email multiple records associated with a single email address, how to do it?
- Thread starter hassan99663
- Start date
hassan99663
New member
Bump
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.
I hope this will be sufficient for your requirements. Let us know your feedback.
Regards,
Seemanto Saha
ExcelDemy
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 SubRegards,
Seemanto Saha
ExcelDemy
Attachments
hassan99663
New member
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
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.
The Excel file is also attached here. Let us know your feedback.
Regards,
Seemanto Saha
ExceldDemy
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 SubRegards,
Seemanto Saha
ExceldDemy
hassan99663
New member
Sir, thank you so much, problem solved it is working perfectly fine.
Dear Hassan,
You are most welcome. Keep sharing your Excel-related problems with us.