selezionare un elenco di email da un foglio Excel

[mflautoPartecipante mflauto]

Buongiorno a tutti, avrei bisogno di un piccolo aiuto per creare un set di istruzioni che mi permettano di selezionare da un foglio chiamato: "Inviti" dalla colonna: "A" i destinatari o gruppi di destinatari a cui voglio inviare un'invito ad una riunione tramite Outlook, se metto una "X" nella colonna: "C" mi deve selezionare l'invito e poi con un pulsante (già creato da me deve posizionare tutti gli indirizzi separati dal punto e virgola, nella cella: "A2" del foglio: "Rubrica", il resto l'ho già creato.

In allegato il file di esempio.

Grazie come sempre per l'aiuto. Massimiliano

Allegati:

You must be logged in to view attached files.

[PMC77Partecipante PMC77Karma: 9 pts]

Ciao @mflauto

Mi sembra strano che tu riesca a creare la macro di invio mail e non a fare un semplice ciclo su una colonna per crearti un elenco di destinatari da inserire nel secondo foglio….

Detto questo se guardi nell'altra sezione del forum uno dei miei ultimi messaggi in risposta a RafBor c'è un ciclo che con pochi aggiustamenti potrebbe fare al caso tuo!

Buona giornata!

Paolo

[mflautoPartecipante mflauto]

Buongiorno Paolo,

ho da poco intrapreso la strada della programmazione, però con un pò di reverse engineering si riesce a fare quasi tutto! grazie per il suggerimento.

Option Explicit
Sub aggiornaScadenze_VF()
Dim v As Variant
Dim OutApp As Object
Dim fdrCalendar As Object
Dim ItemAppt As Object
Dim i As Long, j As Long
Dim bFound As Boolean

    Set OutApp = CreateObject("Outlook.Application")
    Set fdrCalendar = OutApp.GetNamespace("MAPI").GetDefaultFolder(9)    '9 = olFolderCalendar

    OutApp.Session.Logon
    Sheets("ElencoEventi").Select
    For Each v In Range("A1").CurrentRegion.Rows
        If v.Row > 1 Then
            If Trim(v.Cells(3)) = "" Then
                MsgBox "il documento " & v.Cells(1) & " non ha una data scadenza", vbInformation, "campo obbligatorio"
            Else
                '---- check
                For Each ItemAppt In fdrCalendar.Items
                    If ItemAppt.Subject = v.Cells(1) Then
                        bFound = True
                        'trovato subject uguale: verifico se il corpo è uguale, se diverso lo aggiorno
                        'If ItemAppt.Body <> v.Cells(2) Then ItemAppt.Body = v.Cells(2)
                       If ItemAppt.Body <> Trim(WorksheetFunction.Clean(v.Cells(2))) Then ItemAppt.Body = v.Cells(2)
                        'data di scadenza non uguale all'appuntamento già inserito:
                        'cancella appuntamento esistente e lo reinserisce in nuova posizione
                        If ItemAppt.Start <> v.Cells(3) Then
                            ItemAppt.Delete
                            Call CreateItem(OutApp, v)
                            j = j + 1
                        End If
                    End If
                Next
                '--------------------
                If Not bFound Then
                    Call CreateItem(OutApp, v)
                    i = i + 1
                    bFound = False
                End If
            End If
        End If
    Next
    
    Set OutApp = Nothing
    MsgBox "Ho inserito " & i & " scadenze, ho modificato " & j & " scadenze"
End Sub

Private Sub CreateItem(olApp As Object, v As Variant)
Dim OutCalendar As Object
Dim RCP As Range
Set OutCalendar = olApp.CreateItem(1)  'nuovo appuntamento
Set RCP = Worksheets("Rubrica").Range("A2")
    With OutCalendar
        .AllDayEvent = True
        .Start = v.Cells(4).Value     'data & ora delle riunione
        .End = v.Cells(5).Value          'data & ora delle fine riunione
        .Subject = v.Cells(1)       'oggetto dell'evento
        .Location = v.Cells(3)         ' luogo dell'evento
        .Body = v.Cells(2)          'corpo del documento
       ' .ReminderMinutesBeforeStart = 50
        .ReminderSet = True
        .Recipients.Add RCP
        .MeetingStatus = 1      ' 1 = olMeeting
        .Recipients.ResolveAll
      '  .send
        .display
        .Save
    End With
    Set OutCalendar = Nothing
    Set RCP = Nothing
 End Sub

[Autore]

Articoli