Invio Mail da File excel

Question

Buongiorno a tutti!

Avrei la seguente necessità:

Da un file excel avrei bisogno di una macro che mi invii in automatico una mail ogni qualvolta si inserisce in una delle celle della colonna A un numero, inserendo in automatico nell'oggetto della mail il numero inserito.

Rimango in attesa.

Grazie mille!!!

Max

Answer 1

Ciao Andrea,

Chiedo scusa se mi intrometto in questa discussione per suggerire una piccolissima modifica al tuo codice. Più in particolare, vorrei suggerire che la riga

    If IsNumeric(Target.Value) Then

diventi:

    If IsNumeric(Target.Value) And Not IsEmpty(Target.Value) Then

oppure

   If Application.IsNumber(Target.Value) Then

Suggerisco questa piccola modifica per evitare che una e-mail sia spedita in risposta alla cancellazione del contenuto della cella interessata.

===

Regards,

Norman

E' così che è nato lo spam ... ;)

Modifica approvata e modificato anche il codice, se Max ci legge ancora correggerà da solo.

Grazie.

Answer 2

Ciao!

Scusa ma dimenticavo...riesci ad integrarmelo nella mia macro già esistente?

...

Infine, se possibile, nell'oggetto è possibile scrivere del testo libero oltre al numero che viene inserito in automatico?

Grazie ancora in anticipo!

Modifica le parti evidenziate. Il testo aggiuntivo è inserito prima del numero, altrimenti inverti l'ordine.

---

Private Sub Worksheet_Change(ByVal Target As Range)

Dim olApp As Object

Dim wk As Workbook

Dim SH As Worksheet

Dim Rng As Range, Rng2 As Range, rCell As Range

Dim sSubject As String, sBody As String

Dim lRiga As Long

  On Error GoTo XIT

'--- personalizza oggetto e testo della email

sSubject = "Testo aggiuntivo da aggiungere all'oggetto"

sBody = "Corpo del messaggio"

  Application.EnableEvents = False

  If Target.Column = 18 Then

    Select Case UCase(Target.Value)

      Case Is = ""

        Exit Sub

      Case "SI"

        Set wk = Workbooks.Open("Y:\Giro librerie\2 - INSTALL RPR - PRO\NEW ITER" _

                                & "Comunicazioni a Utenti - Installazione PATCH.xlsm")

        Set SH = wk.Worksheets("COMUNICAZIONE")

        With SH

          lRiga = .Range("A" & .Rows.Count).End(xlUp).Row + 1

          .Range("A" & lRiga).Value = Me.Range("C" & Target.Row).Value

          lRiga = .Range("B" & .Rows.Count).End(xlUp).Row + 1

          .Range("B" & lRiga).Value = Me.Range("A" & Target.Row).Value

          lRiga = .Range("C" & .Rows.Count).End(xlUp).Row + 1

          .Range("C" & lRiga).Value = Me.Range("B" & Target.Row).Value

        End With

    End Select

  ElseIf Target.Column = 1 Then

    Target.Offset(0, 5).Value = Date

    Target.Offset(0, 8).Value = "NON INSTALLATO"

    '--- spedisce email se numero

If Application.IsNumber**(Target.Value) Then**

      On Error Resume Next

      Set olApp = GetObject(, "Outlook.Application")

      If Err.Number <> 0 Then

        Set olApp = CreateObject("Outlook.Application")

      End If

      With olApp.CreateItem(0)

        .To = "******@domain.com"

.Subject = sSubject & CStr(Target.Value)

        .body = sBody

        .Send

      End With

      Set olApp = Nothing

    End If

    On Error GoTo XIT

    '-----------------------------

  ElseIf Target.Column = 9 Then

    If Not Intersect(Target, Me.Range("I5:I81")) Is Nothing Then

      If Not Target.Count > 1 Then

        '                for each

        Select Case UCase(Target.Value)

          Case Is = "INSTALLATO"

              Target.Offset(0, 4).Value = Target.Offset(0, -2).Value

              Target.Offset(0, 5).Value = "Da Testare"

          Case Is = "NON INSTALLATO"

          Case Else

        End Select

      End If

    End If

  End If

  Set Rng = Application.Union(Me.Range("J5:J81"), Me.Range("P5:P81"))

  On Error Resume Next

  Set Rng2 = Intersect(Target, Rng)

  On Error GoTo XIT

  If Not Rng2 Is Nothing Then

    For Each rCell In Rng2.Cells

      With rCell

        If UCase(.Value) = "SOLARI" Then

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

        Else

          .Offset(0, 1).Value = vbNullString

        End If

      End With

    Next rCell

  End If

XIT:

   Application.EnableEvents = True

End Sub

---

Nota:

Modificato il controllo numericità segnalato da Norman.

Answer 3

PERFETTISSIMO!

GRAZIE!

Answer 4

Ciao!

Scusa ma dimenticavo...riesci ad integrarmelo nella mia macro già esistente?

Private Sub Worksheet_Change(ByVal Target As Range)

     Dim OutApp As Object

     Dim OutMail As Object

     Dim a As String

Dim wk As Workbook

    Dim SH As Worksheet

    Dim lRiga As Long

     Dim Rng As Range, Rng2 As Range

     Dim rCell As Range

     On Error GoTo XIT

    Application.EnableEvents = False

     If Target.Column = 18 Then

         Select Case UCase(Target.Value)

             Case Is = ""

                 Exit Sub

             Case "SI"

                 Set wk = Workbooks.Open("Y:\Giro librerie\2 - INSTALL RPR - PRO\NEW ITER" _

                                         & "Comunicazioni a Utenti - Installazione PATCH.xlsm")

                 Set SH = wk.Worksheets("COMUNICAZIONE")

                 With SH

                     lRiga = .Range("A" & .Rows.Count).End(xlUp).Row + 1

                     .Range("A" & lRiga).Value = Me.Range("C" & Target.Row).Value

                     lRiga = .Range("B" & .Rows.Count).End(xlUp).Row + 1

                     .Range("B" & lRiga).Value = Me.Range("A" & Target.Row).Value

                     lRiga = .Range("C" & .Rows.Count).End(xlUp).Row + 1

                     .Range("C" & lRiga).Value = Me.Range("B" & Target.Row).Value

                 End With

         End Select

     ElseIf Target.Column = 1 Then

         Target.Offset(0, 5).Value = Date

         Target.Offset(0, 8).Value = "NON INSTALLATO"

     ElseIf Target.Column = 9 Then

         If Not Intersect(Target, Me.Range("I5:I81")) Is Nothing Then

             If Not Target.Count > 1 Then

                 '                for each

                 Select Case UCase(Target.Value)

                     Case Is = "INSTALLATO"

                         Target.Offset(0, 4).Value = Target.Offset(0, -2).Value

                         Target.Offset(0, 5).Value = "Da Testare"

                     Case Is = "NON INSTALLATO"

                     Case Else

                 End Select

             End If

         End If

     End If

    Set Rng = Application.Union(Me.Range("J5:J81"), Me.Range("P5:P81"))

    On Error Resume Next

    Set Rng2 = Intersect(Target, Rng)

    On Error GoTo XIT

    If Not Rng2 Is Nothing Then

        For Each rCell In Rng2.Cells

            With rCell

                If UCase(.Value) = "SOLARI" Then

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

                Else

                    .Offset(0, 1).Value = vbNullString

                End If

            End With

        Next rCell

    End If

XIT:

    Application.EnableEvents = True

 End Sub

Infine, se possibile, nell'oggetto è possibile scrivere del testo libero oltre al numero che viene inserito in automatico?

Grazie ancora in anticipo!

Answer 5

Buongiorno a tutti!

Avrei la seguente necessità:

Da un file excel avrei bisogno di una macro che mi invii in automatico una mail ogni qualvolta si inserisce in una delle celle della colonna A un numero, inserendo in automatico nell'oggetto della mail il numero inserito.

Rimango in attesa.

Grazie mille!!!

Max

Da incollare nel modulo del foglio interessato.

---

Private Sub Worksheet_Change(ByVal Target As Range)

  If Target.Count > 1 Then Exit Sub

  If Not Intersect(Target, Me.Columns(1)) Is Nothing Then

    If IsNumeric(Target.Value) Then

      Dim olApp As Object

      On Error Resume Next

      Set olApp = GetObject(, "Outlook.Application")

      If Err.Number <> 0 Then

        Set olApp = CreateObject("Outlook.Application")

      End If

      With olApp.CreateItem(0)

        .To = "******@domain.com"

        .Subject = CStr(Target.Value)

        .body = "Corpo del messaggio"

        .Send

      End With

      Set olApp = Nothing

    End If

  End If

End Sub

---