excel vba - Outlook Email Macro -
i have mention code , works unique records, problem sends multiple emails 1 email id.
email id's n column w (1st record w6) , body of mail in column x6 have merge body code "wsht.cells(i, 25) = sbody"
any idea work wil send 1 email
for eg:- in w7 email id xxx@gmail.com , in w10 email id xxx@gmail.com code# send 2 mails, should send 1 email xxx@gmail.com
any idea or update.
private sub commandbutton3_click() dim outapp object dim outmail object set outapp = createobject("outlook.application") application .enableevents = false .screenupdating = false end dim wsht worksheet dim lastrow long, lcuenta long dim integer, k integer dim sto string, ssbject string, sbody string set wsht = activesheet lastrow = cells(rows.count, 1).end(xlup).row = 6 lastrow lcuenta = application.worksheetfunction.countif(range("w6:w" & i), range("w" & i)) if lcuenta = 1 ssubject = "pd call back" sto = wsht.cells(i, 1) sbody = wsht.cells(i, 24) k = lastrow if wsht.cells(i, 1).value = wsht.cells(k + 1, 1).value 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 outmail .to = sto .subject = ssubject .body = sbody .send end next end sub
your problem occurring because testing whether or not first time email id has been used and, if isn't, resending last email set up.
the end if test needs moved after section sends email:
private sub commandbutton3_click() dim outapp object dim outmail object set outapp = createobject("outlook.application") application .enableevents = false .screenupdating = false end dim wsht worksheet dim lastrow long, lcuenta long dim integer, k integer dim sto string, ssbject string, sbody string set wsht = activesheet lastrow = cells(rows.count, 1).end(xlup).row = 6 lastrow lcuenta = application.worksheetfunction.countif(range("w6:w" & i), range("w" & i)) if lcuenta = 1 ssubject = "pd call back" sto = wsht.cells(i, 1) sbody = wsht.cells(i, 24) k = lastrow if wsht.cells(i, 1).value = wsht.cells(k + 1, 1).value sbody = sbody & vbnewline & wsht.cells(k + 1, 24).value end if wsht.cells(i, 25) = sbody next k 'end if '<-- move set outmail = outapp.createitem(0) on error resume next outmail .to = sto .subject = ssubject .body = sbody .send end end if '<-- here next end sub
Comments
Post a Comment