VBA Code to reject value in sheet1 if already in sheet2 and if not in sheet 2 move the said value to sheet 3 and send email to client

[WillemS]

Good day

I need some help please combining 2 sets of code to run as one set of code for one process.

Reference back to the below link for additional details on the first portion.

VBA Code to reject value in sheet1 if already in sheet2 and if not in sheet 2 move the said value to sheet 3

My excel workbook has the following tabs

Mail
Sheet1
Sheet2
Sheet3

The first portion of code, see below, is doing the following on its own when you run it separately.

The code must perform the following: Various email addresses arrive in the Mail sheet via an auto-export from Outlook of which the said refresh every minute into the Mail sheet. The exported info from outlook into the Mail sheet are not text or a value and some help are needed here to get it displayed as text or a value as the process described from here on will not work as the VBA code see the info received as a link back to outlook and can not move and or action the data as per the process to follow. The said info populate in the Mail sheet from cell A2 and below as there is a heading in cell A1 on the Mail sheet. The requirement will be as soon as a new email address arrives in cell A2 in the Mail sheet, and or any cell below A2, in the Mail sheet, the code must then look when the email addresses arrived in the Mail sheet, from A2 and or below if the said are already in sheet2 from cell A2 downwards. If already in Sheet 2, in the specific place already noted, it then must be moved to Sheet3 from cell A2 and below and if not in sheet2 as per the already identified position, it must then move to Sheet1 from cell A2 and below. The whole process must run automatically as and when the email addresses arrive in the Mail sheet from A2 onwards.

Herewith the code for the above, excluding the portion where I refer to the issue where the info from outlook came into excel as a link and not as a value and or text.

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Count = 1 Then

With Worksheets("sheet2")

Last2 = .Cells(Rows.Count, "A").End(xlUp).Row

elist = .Range(.Cells(1, 1), .Cells(Last2, 1))

fnd = False

For i = 1 To UBound(elist, 1)

If Target.Value = elist(i, 1) Then

fnd = True

Exit For

End If

Next i

End With



If fnd Then

With Worksheets("sheet3")

Last3 = .Cells(Rows.Count, "A").End(xlUp).Row

.Range(.Cells(Last3 + 1, 1), .Cells(Last3 + 1, 1)) = Target.Value

End With

Else

With Worksheets("sheet1")

Last1 = .Cells(Rows.Count, "A").End(xlUp).Row

.Range(.Cells(Last1 + 1, 1), .Cells(Last1 + 1, 1)) = Target.Value

End With

End If

End If

End Sub

Once the above process is completed, herewith the second part of code that is currently running behind Sheet1 and which is working 100% doing the following

The VBA code “look” at cell A2 and below in Sheet1 awaiting the arrival for the email address as described in the first portion of this request. Once an email address is received in A2 and or below in Sheet 1 the code, see below will use my outlook account to send a specific email, see the wording in the code below, to a customer linked to the email address received in cell A2 in Sheet 1 where after the code will move the said email address received in A2 in Sheet1 to Sheet 2 in column A.

As you can see this info in Sheet2 is then being used to link back to the first part to prevent duplications, as per the already described process in the first portion.

Herewith the second part of the code

Private Function CheckValue(ByVal Target As Range) As Boolean

Dim bResult As Boolean

If Not IsArray(Target.Value) Then

bResult = Trim(Target.Value & "") <> ""

End If

CheckValue = bResult

End Function

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo errHandler

With Target

If .CountLarge = 1 And .Column = 1 Then

If CheckValue(Target) Then

Send_Email Target

Else

MsgBox "Email cannot be blank", vbInformation, "Error Message"

End If

End If

End With

errHandler:

If Err.Number <> 0 Then

MsgBox "Client Email maybe not valid / not completed", vbInformation, "Error Message"

Err.Clear

End If

End Sub

Sub Send_Email(Target As Range)



Dim mail As Object, bodyString As String

bodyString = bodyString & "Good Day" & vbNewLine & vbNewLine

bodyString = bodyString & "Trust you are well." & vbNewLine & vbNewLine

bodyString = bodyString & "Thank you for your request." & vbNewLine & vbNewLine

bodyString = bodyString & "Much appreciated" & vbNewLine & vbNewLine

bodyString = bodyString & "Thank you" & vbNewLine & vbNewLine

bodyString = bodyString & "Kind Regards" & vbNewLine & vbNewLine



With CreateObject("Outlook.Application")

Set mail = .createitem(0)

With mail

.To = Target.Value

.Subject = "7 Enter your subject line here"

.body = bodyString

'.attachments.Add "C:\Users\xxxxxx.zzzzzz\Desktop\Form.docx" ''Replace this address with your file location''

.send

End With

End With

Much appreciated

 

[offthelip]

If I have understood correctly I think you can do it very easily.
Firstly move all the code from sheet 1 into a standard module. then change the private worksheet_change event sub to a non event driven sub . I have chosen "sendmail"
then call the sendmail from the event driven code on the mail sheet
like this:
In standard module:

Private Function CheckValue(ByVal Target As Range) As Boolean
Dim bResult As Boolean
If Not IsArray(Target.Value) Then
bResult = Trim(Target.Value & "") <> ""
End If
CheckValue = bResult
End Function

Sub sendmail(ByVal Target As Range)
On Error GoTo errHandler
With Target
If .CountLarge = 1 And .Column = 1 Then
If CheckValue(Target) Then
Send_Email Target
Else
MsgBox "Email cannot be blank", vbInformation, "Error Message"
End If
End If
End With
errHandler:
If Err.Number <> 0 Then
MsgBox "Client Email maybe not valid / not completed", vbInformation, "Error Message"
Err.Clear
End If
End Sub

Sub Send_Email(Target As Range)
Dim mail As Object, bodyString As String
bodyString = bodyString & "Good Day" & vbNewLine & vbNewLine
bodyString = bodyString & "Trust you are well." & vbNewLine & vbNewLine
bodyString = bodyString & "Thank you for your request." & vbNewLine & vbNewLine
bodyString = bodyString & "Much appreciated" & vbNewLine & vbNewLine
bodyString = bodyString & "Thank you" & vbNewLine & vbNewLine
bodyString = bodyString & "Kind Regards" & vbNewLine & vbNewLine
With CreateObject("Outlook.Application")
Set mail = .createitem(0)
With mail
.To = Target.Value
.Subject = "7 Enter your subject line here"
.body = bodyString
'.attachments.Add "C:\Users\xxxxxx.zzzzzz\Desktop\Form.docx" ''Replace this address with your file location''
.send
End With
End With
End Sub

then in the workhseet change of the mail sheet add one line:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count = 1 Then
With Worksheets("sheet2")
Last2 = .Cells(Rows.Count, "A").End(xlUp).Row
elist = .Range(.Cells(1, 1), .Cells(Last2, 1))
fnd = False
For i = 1 To UBound(elist, 1)
If Target.Value = elist(i, 1) Then
fnd = True
Exit For
End If
Next i
End With

If fnd Then
With Worksheets("sheet3")
Last3 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range(.Cells(Last3 + 1, 1), .Cells(Last3 + 1, 1)) = Target.Value
End With
Else
With Worksheets("sheet1")
Last1 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range(.Cells(Last1 + 1, 1), .Cells(Last1 + 1, 1)) = Target.Value
Call sendmail(Target)  ' add this line
End With
End If
End If
End Sub

Note Untested!!!!