Invio email ad un numero specifico di indirizzi su Excel

Question

Buon pomeriggio,

come faccio ad inviare un'email ad un numero specifico di indirizzi email?

Nella colonna D ho circa 1000 email ed inviarle tutte mi si bloccherebbe il computer..sarebbe possibile inviare tipo 10 email al giorno,sempre dalla colonna D?

Ad esempio, oggi partendo dalla riga 2 (inizio indirizzi email) fino alla riga 12;

domani dalla riga 13 alla riga 23...e così via..

Attualmente sto usando il seguente codice:

`Dim EmailAddr As String Dim Subj As String Dim StrMsg As String Dim uR As Long Dim i As Long Dim OutApp As Object Dim OutMail As Object Dim Subject As String

Sheet1.Select

Set OutApp = CreateObject("Outlook.Application") Set wk1 = ThisWorkbook Set sh = wk1.Worksheets("Sheet1") uR = Worksheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row

StrMsg = StrMsg & "prova" For i = 2 To uR

destinatario = Worksheets("Sheet1").Range("D" & i) Set OutMail = OutApp.CreateItem(0)

With OutMail   .To = destinatario   .Subject = "PROVA"   .HTMLBody = StrMsg     .Attachments.Add ("C:\Users...\document.pdf")   .Attachments.Add ("C:\Users....\cartel1.zip")   .Display   '.Send   Application.Wait (Now + TimeValue("0:00:10")) End With

Cells(i, 6) = "x" Next End Sub`

Spero non stia chiedendo nulla di fantascientifico...

Buona giornata :)

Answer 1

Ciao Sol39,

ti chiedo umilmente scusa, ma effettivamente non avevo modificato la lettera della colonna contenente gli indirizzi email e quella che dovrebbe contenere le x.

Ho fatto la prova con 2 email e funziona alla perfezione ;) :D

Ti ringrazio tantissimo per la pazienza che hai avuto con me :)

Ti auguro buona giornata

Grazie a te per il cortese riscontro.

Per chiudere questo thread, vorrei chiederti gentilmente di contrassegnare la mia risposta come risposta preferita.

===

Regards,

Norman 

Answer 2

Ciao Norman,

ti chiedo umilmente scusa, ma effettivamente non avevo modificato la lettera della colonna contenente gli indirizzi email e quella che dovrebbe contenere le x.

Ho fatto la prova con 2 email e funziona alla perfezione ;) :D

Ti ringrazio tantissimo per la pazienza che hai avuto con me :)

Ti auguro buona giornata

Answer 3

Ciao  Sol39,

Ciao Norman,

ho provato ma mi chiude la macro appena clicco su Esegui non facendo niente :(

Purchè gli indirizzi email si trovino nella colonna E  che ogni corrispondente cella nella colonna F non sia contrssegnato con una x, a me il codice funziona nel modo previsto e senza alcun problema.

Pertanto, ti chiederei gentilmente di caricare il file problematico, dopo averlo depurato dei dati sensibili, su un servizio di condivisione di file, ad esempio Microsoft OneDrive o DropBox, e postare un link al file in una risposta qui.

Per caricare il file su Microsoft OneDrive, vedi:

      Condividere file e cartelle di OneDrive

Nel caso di DropBox, vedi:

Come faccio a condividere file e cartelle in Dropbox?

===

Regards,

Norman

Answer 4

Ciao Norman,

ho provato ma mi chiude la macro appena clicco su Esegui non facendo niente :(

Answer 5

Ciao ,

come faccio ad inviare un'email ad un numero specifico di indirizzi email?

Nella colonna D ho circa 1000 email ed inviarle tutte mi si bloccherebbe il computer..sarebbe possibile inviare tipo 10 email al giorno,sempre dalla colonna D?

Ad esempio, oggi partendo dalla riga 2 (inizio indirizzi email) fino alla riga 12;

domani dalla riga 13 alla riga 23...e così via..

Attualmente sto usando il seguente codice:

`Dim EmailAddr As String Dim Subj As String Dim StrMsg As String Dim uR As Long Dim i As Long Dim OutApp As Object Dim OutMail As Object Dim Subject As String

Sheet1.Select

Set OutApp = CreateObject("Outlook.Application") Set wk1 = ThisWorkbook Set sh = wk1.Worksheets("Sheet1") uR = Worksheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row

StrMsg = StrMsg & "prova" For i = 2 To uR  

destinatario = Worksheets("Sheet1").Range("D" & i) Set OutMail = OutApp.CreateItem(0)

With OutMail   .To = destinatario   .Subject = "PROVA"   .HTMLBody = StrMsg     .Attachments.Add ("C:\Users...\document.pdf")   .Attachments.Add ("C:\Users....\cartel1.zip")   .Display   '.Send   Application.Wait (Now + TimeValue("0:00:10")) End With

Cells(i, 6) = "x" Next End Sub`

Spero non stia chiedendo nulla di fantascientifico...

Buona giornata :)

Prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim OutApp As Object

    Dim OutMail As Object

    Dim wk1 As Workbook

    Dim SH As Worksheet

    Dim rCell As Range, rng As Range

    Dim EmailAddr As String

    Dim Subj As String

    Dim StrMsg As String

    Dim sDestinatario As String

    Dim uR As Long

    Const iNumero_Email As Long = 10

    Set OutApp = CreateObject("Outlook.Application")

    Set wk1 = ThisWorkbook

    Set SH = wk1.Worksheets("Sheet1")

    With SH

        uR = LastRow(SH, .Columns("F:F"), 2)

        Set rng = .Range("E" & uR).Resize(iNumero_Email)

    End With

    StrMsg = StrMsg & "prova"

    For Each rCell In rng.Cells

        With rCell

            If Not IsEmpty(.Value) Then

                sDestinatario = .Value

                Set OutMail = OutApp.CreateItem(0)

                With OutMail

                    .to = sDestinatario

                    .Subject = "PROVA"

                    .HTMLBody = StrMsg

                    .Attachments.Add ("C:\Users...\document.pdf")

                    .Attachments.Add ("C:\Users....\cartel1.zip")

                    .Display

                    '.Send

                End With

                .Offset(0, 1).Value = "x"

            End If

        End With

    Next rCell

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If rng Is Nothing Then

            Set rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            Application.ScreenUpdating = False

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = rng.Find(What:="*", _

                       after:=rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

    Application.ScreenUpdating = True

End Function

'<<=========

===

Regards,

Norman