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
Sir thank you for the support but it is not working as desire. The code is emailing whole sheet in a email.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.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
Regards,
Seemanto Saha
ExcelDemy
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
Dear Hassan,Sir, thank you so much, problem solved it is working perfectly fine.