AW: Termine per Makro von Excel nach Outlook exportier
29.09.2012 10:58:28
Excel
Hallo,
hier mal ein Beispiel, Daten stehen so in der Tabelle1.
Tabelle1
| | A | B | C | D | E | F | G | H |
| 1 | | | | | | | | |
| 2 | | | | | | | | |
| 3 | Betreff | Beginntam | Beginntum | Endetam | Endetum | Kategorie | Ort | Zeitspannezeigenals |
| 4 | Telefondienst | 01.01.2013 | 8:00 | 01.01.2013 | 18:00 | | | 3 |
| 5 | | | | | | | | 3 |
| 6 | Telefondienst | 03.01.2013 | 8:00 | 03.01.2013 | 18:00 | | | 3 |
| 7 | | | | | | | | 3 |
| 8 | | | | | | | | 3 |
| 9 | | | | | | | | 3 |
| 10 | | | | | | | | 3 |
| 11 | Telefondienst | 08.01.2013 | 8:00 | 08.01.2013 | 17:00 | | | 3 |
| 12 | | | | | | | | 3 |
| 13 | Telefondienst | 10.01.2013 | 8:00 | 10.01.2013 | 17:00 | | | 3 |
Code in einem Standard Modul, die Sub Start evtl. einem Button auf der Tabelle zuweisen.
kommt als Code in Modul1
Option Explicit
Dim objOutlook As Object, objNameSpace As Object
Dim objMapiFolder As Object
Sub Start()
Dim ArrayData(), n&, nn&, strBody$
strBody = "Excel-Termin" 'evtl. anpassen oder löschen
With Tabelle1
n = .Cells(.Rows.Count, 1).End(xlUp).Row
If n < 4 Then Exit Sub
ArrayData = .Range("A4", .Cells(n, 1)).Resize(, 8)
End With
VerbindungOutlook False
With Application.WorksheetFunction
For n = 1 To Ubound(ArrayData)
If ArrayData(n, 1) <> "" Then
If ArrayData(n, 2) <> "" And ArrayData(n, 3) <> "" Then
If ArrayData(n, 4) <> "" And ArrayData(n, 5) <> "" Then
TermineSchreiben ArrayData(n, 1), CDate(.Sum(ArrayData(n, 2), ArrayData(n, 3))), CDate(.Sum(ArrayData(n, 4), ArrayData(n, 5))), strBody
End If
End If
End If
Next n
End With
VerbindungOutlook True
MsgBox "fertig"
End Sub
Sub VerbindungOutlook(booCancel As Boolean)
If booCancel Then
Set objNameSpace = Nothing
Set objNameSpace = Nothing
Set objMapiFolder = Nothing
Else
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objMapiFolder = objNameSpace.GetDefaultFolder(9)
End If
End Sub
'Für Termine ********************************************************************************************
Sub TermineSchreiben(ByVal strBetreff As String, ByVal vonDatum As Date, ByVal bisDatum As Date, strBody As String)
Dim LMinuten As Long
Dim booFind As Boolean
Dim objItems As Object
'dauer in Minuten berechnen
LMinuten = Application.WorksheetFunction.Round((bisDatum - vonDatum) * 1440, 0)
Set objItems = objMapiFolder.Items
objItems.Sort "[Start]"
objItems.IncludeRecurrences = True
Set objItems = objItems.Restrict("[Start] >= '" & Format(vonDatum, "dd.mm.yyyy hh:mm") & "'" & _
"AND [Start] <= '" & Format(vonDatum + 1, "dd.mm.yyyy hh:mm") & "'")
'Schleife durch alle gefundenen Termine bis Start und Betreff übereinstimmen
For Each objItems In objItems
With objItems
If .Start = vonDatum And .Subject = strBetreff Then
booFind = True
Exit For
End If
End With
Next objItems
If booFind Then
'hier berabeiten *************************
With objItems
.body = strBody
.Duration = bisDatum 'tauer in Minuten
.Save
End With
Else
'hier anlegen *************************
Set objItems = objMapiFolder.Items.Add
With objItems
.Subject = strBetreff
.body = strBody
.Start = Format(vonDatum, "dd.mm.yyyy hh:mm")
.Duration = LMinuten 'dauer in Minuten
.Save
End With
End If
Set objItems = Nothing
End Sub
Gruß Tino