1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
| Option Explicit
Sub NouveauRDV_Calendrier()
'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim myOlApp As New Outlook.Application
Dim MyItem As Outlook.AppointmentItem
Dim Cell As Range
Dim dLgC As Long, dLgR As Long
For Each Cell In Range("A8:A" & Range("A22").End(xlUp).Row)
Set MyItem = myOlApp.CreateItem(olAppointmentItem)
With MyItem
.MeetingStatus = olNonMeeting
.Subject = Cell
.Start = Cell.Offset(0, 2)
.AllDayEvent = True
.Location = Cell.Offset(0, 1)
.Save
End With
Set MyItem = Nothing
Next Cell
With Sheets("Feuil1")
dLgC = .Range("A65536").End(xlUp).Row
If dLgC = 7 Then MsgBox "Il n'y a pas de données à transférer dans la feuille Resultats": End
Range("A8:C" & dLgC).Copy
End With
With Sheets("Feuil2")
dLgR = .Range("A65536").End(xlUp).Row + 1
.Range("A" & dLgR).PasteSpecial Paste:=xlPasteValues
End With
Sheets("Feuil1").Range("A8:C22").ClearContents
Sheets("Feuil2").Select
End Sub |
Partager