Conditionally Email (Outlook) Row on Change

[LBinGA]

Hi all:

I have the code to email through Outlook but I need to change it up a bit.

I have 600+ Rows of data. If someone enters "Y" in the T Column, a Macro should open Outlook and include in the body only the Row of Data that the "Y" was just entered into (On Change).

The EmailAddr will be static, but the Row will not be. It should ignore all other "Y"s in Column T. It will be a single email for each new "Y" entered.

For instance, imagine that the end user just entered "Y" in T3. Outlook should open an email containing all the contents of Row 3 only.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Address[/TD]
[TD]City[/TD]
[TD]St[/TD]
[TD]Entered? (Col T)[/TD]
[/TR]
[TR]
[TD]Joe Smith[/TD]
[TD]123 Easy Street[/TD]
[TD]Atlanta[/TD]
[TD]GA[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mary Smith[/TD]
[TD]321 Easy Street[/TD]
[TD]Dahlonega[/TD]
[TD]GA[/TD]
[TD="align: center"]Y[/TD]
[/TR]
[TR]
[TD]John Hancock[/TD]
[TD]111 Easy Street[/TD]
[TD]Chicago[/TD]
[TD]IL[/TD]
[TD="align: center"][/TD]
[/TR]
</tbody>[/TABLE]


Thanks in advance,

LBinGA

 

[LBinGA]

Anybody?

 

[LBinGA]

How about if I used a UserForm to enter the data and when the button is clicked to enter the data to the sheet, it provides a Choice box of whether or not to send an email containing the same row data?

I have code to enter a Row alphabetically as follows. It searches the Company Name and copies down data from the row above if the company name matches the one above it:

Sub InsertContact()Dim sNewName As String
Dim lPosition As Long
Dim rEmpList As Range


Set rEmpList = Range("D7:D1000")


sNewName = InputBox("Enter Name of Company for added Contact")
On Error Resume Next 'if Company needs to go at start of list, Match will return [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=NA]#NA[/URL] 
lPosition = Application.WorksheetFunction.Match(sNewName, rEmpList, 1)
On Error GoTo 0 'revert to normal error handling (crashing)
rEmpList(lPosition + 1).EntireRow.Insert
rEmpList(lPosition + 1).Value = sNewName
rEmpList(lPosition + 1).Activate


If ActiveCell.Offset(-1, 0).Value = ActiveCell.Value Then
    Range(ActiveCell.Offset(-1, 9), ActiveCell.Offset(-1, 9)).Copy ActiveCell.Offset(0, 9)
    
    End If
End Sub

I'm unsure how to change and move this code to a Userform & make all the text boxes fill the data onto Sheet 16 from there. Any help would be appreciated.

Thanks,
LB in GA

 

[LBinGA]

I solved this issue by using the following code, which sends a hightlighted row in an email...in case anyone else has a similar issue:

Sub SendMailforDrip()

Dim OutlookApp As Object: Set OutlookApp = CreateObject("Outlook.Application")
Dim var As Variant: var = Selection.Value
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Msg As String
    
'Create Outlook object & set Subj & Body
       
Subj = "This is the Subject"
strbody = "Hi," & vbNewLine & vbNewLine & "Please see the following:" & vbNewLine & vbNewLine & "Company: " & var(1, 1) & vbNewLine & "Contact Name: " & var(1, 4) & vbNewLine & vbNewLine & "Let me know if you have any questions." & vbNewLine & vbNewLine & "Thank you,"


 Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
                    .To = "email@emailaddress.com"
                    .CC = ""
                    .BCC = ""
                    .Subject = Subj
                    .Body = strbody
                    .Display
                End With
    
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    


End Sub