Email masivo (macros ya echa, solo necesito una modificación por favor)
publicado
Buenas Tardes amigos, aca saludos desde Chile, quisiera vuestra ayuda , tengo este Excel el cual ocupamos cada 5 dias para enviar email masivos, enviamos aprox. 10.000 email, el tema es que cada email no tengo idea el porque, pero pesa entre 500 kg a 1 mega Aprox. y esto demora mucho, no se si se podrá hacer algo, y lo otro, para cada mensaje debe ser personalizado si es hombre y mujer, habrá alguna forma de dejarlo unido si determina si es mujer u hombre? le dejo el macros en caso me puedas ayudar para optimizar el macros que tengo por favor.
Se activa el macros, este copia el mensaje que esta en la hoja Datos y lo pega en un correo nuevo en el Outlook , fue la unica opcion que pude lograr, no se si habra otra forma.
Buenas Tardes amigos, aca saludos desde Chile, quisiera vuestra ayuda , tengo este Excel el cual ocupamos cada 5 dias para enviar email masivos, enviamos aprox. 10.000 email, el tema es que cada email no tengo idea el porque, pero pesa entre 500 kg a 1 mega Aprox. y esto demora mucho, no se si se podrá hacer algo, y lo otro, para cada mensaje debe ser personalizado si es hombre y mujer, habrá alguna forma de dejarlo unido si determina si es mujer u hombre? le dejo el macros en caso me puedas ayudar para optimizar el macros que tengo por favor.
Se activa el macros, este copia el mensaje que esta en la hoja Datos y lo pega en un correo nuevo en el Outlook , fue la unica opcion que pude lograr, no se si habra otra forma.
Sub ENVIARCORREONUEVO1211()
Application.ScreenUpdating = False
ThisWorkbook.Sheets("RS1").Select
ActiveSheet.Range("B1:B26").Select
x = ThisWorkbook.Sheets("Datos").Range("E5").Value
For i = 1 To x
ThisWorkbook.Sheets("Datos").Range("E6").Value = i
ActiveWorkbook.EnvelopeVisible = True
Application.ScreenUpdating = False
With ActiveSheet.MailEnvelope
.Item.To = ThisWorkbook.Sheets("Datos").Range("E2").Value
''.Item.cc = Con Copia a....''
.Item.Subject = ThisWorkbook.Sheets("Datos").Range("E3").Value
' .Introduction = ThisWorkbook.Sheets("Datos").Range("E4").Value '
.Item.Send
End With
Next i
Application.ScreenUpdating = True
End Sub