create send email button per line

If I understand you correctly you want to send the first row and than a certain row below it? (please confirm or elaborate)

To send an email you will atleast need a cell on each row that shows the email of the recipient and a subject is also very useful.

I've managed to kind of do it using:

Sub Line3()


Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object

Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)

With newEmail
.To = Sheet1.Range("A3").Text
.CC = ""
.BCC = ""
.Subject = "Data"
.Body = "Please find the requested information" & vbCrLf & "Best Regards"
.display

Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor

Sheet1.Range("B1:S1, B3:S3").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

Set newEmail = Nothing
Set outlook = Nothing

End Sub



The only problem is that Sheet1.Range("B1:S1, B3:S3").Copy also copies B2:S2 on to the email

any ideas why?