Outlook Email Macro - excel

Question

I have the mention code and it works all well with unique records, but the only problem is it sends multiple emails to 1 email id.
Email ID's are n column W (1st record is w6) and body of the mail is in column x6
have merge the body with code "wsht.cells(i, 25) = sbody"
any idea as who will this work were it wil send 1 email
for eg:- in w7 email id is xxx#gmail.com and in w10 email id is xxx#gmail.com
currently the code# send 2 mails, but it should send only 1 email to xxx#gmail.com
Any idea or update.
Private Sub CommandButton3_Click()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim wSht As Worksheet
Dim LastRow As Long, lCuenta As Long
Dim i As Integer, k As Integer
Dim sTo As String, sSbject As String, sBody As String
Set wSht = ActiveSheet
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 6 To LastRow
lCuenta = Application.WorksheetFunction.CountIf(Range("W6:W" & i), Range("W" & i))
If lCuenta = 1 Then
ssubject = "PD Call Back"
sTo = wSht.Cells(i, 1)
sBody = wSht.Cells(i, 24)
For k = i To LastRow
If wSht.Cells(i, 1).Value = wSht.Cells(k + 1, 1).Value Then
sBody = sBody & vbNewLine & wSht.Cells(k + 1, 24).Value
End If
wSht.Cells(i, 25) = sBody
Next k
End If
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sTo
.Subject = ssubject
.body = sBody
.Send
End With
Next i
End Sub

Answer 1

Your problem is occurring because you are testing whether or not this is the first time that the email id has been used and, if it isn't, you are resending the last email you set up.
The End If for your test needs to be moved after the section which sends the email:
Private Sub CommandButton3_Click()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim wSht As Worksheet
Dim LastRow As Long, lCuenta As Long
Dim i As Integer, k As Integer
Dim sTo As String, sSbject As String, sBody As String
Set wSht = ActiveSheet
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 6 To LastRow
lCuenta = Application.WorksheetFunction.CountIf(Range("W6:W" & i), Range("W" & i))
If lCuenta = 1 Then
ssubject = "PD Call Back"
sTo = wSht.Cells(i, 1)
sBody = wSht.Cells(i, 24)
For k = i To LastRow
If wSht.Cells(i, 1).Value = wSht.Cells(k + 1, 1).Value Then
sBody = sBody & vbNewLine & wSht.Cells(k + 1, 24).Value
End If
wSht.Cells(i, 25) = sBody
Next k
'End If '<-- Move this
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sTo
.Subject = ssubject
.body = sBody
.Send
End With
End If '<-- To here
Next i
End Sub