Abgleich Outlook-Aufg mit Excel unter 2007 mgl?

Sub AufgabenEigenschaftSchreiben(AufgID_ As Integer, EigID_ As Integer, Eigenschaft_ As Variant) _
Dim ue As Integer
If AufgID_ = 0 Then
For ue = 1 To UBound(Ueberschriften)
wsExcel.Cells(AufgID_ + yOffset, ue + xOffset).Value = Ueberschriften(ue)
Next ue
Else
wsExcel.Cells(AufgID_ + yOffset, EigID_ + xOffset).Value = Eigenschaft_
End If 'AufgID=0
End 

Sub 'AufgabenEigenschaftSchreiben
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _


Function EigenschaftValidieren(Eigenschaft_ As Date, Typ_ As Integer) As Variant
Select Case Typ_
Case iDatum
If (Eigenschaft_ = 949998) Then
EigenschaftValidieren = "-"
Else
EigenschaftValidieren = Eigenschaft_
End If
Case iStatus
Select Case Eigenschaft_
Case olTaskNotStarted
EigenschaftValidieren = "Nicht begonnen"
Case olTaskInProgress
EigenschaftValidieren = "In Bearbeitung"
Case olTaskComplete
EigenschaftValidieren = "Erledigt"
Case olTaskWaiting
EigenschaftValidieren = "Wartet auf jemand anderen"
Case olTaskDeferred
EigenschaftValidieren = "Zurückgestellt"
End Select 'iStatus
Case iWichtigkeit
Select Case Eigenschaft_
Case olImportanceLow
EigenschaftValidieren = "Niedrig"
Case olImportanceNormal
EigenschaftValidieren = "Normal"
Case olImportanceHigh
EigenschaftValidieren = "Hoch"
End Select 'iWichtigkeit
Case iVertraulichkeit
Select Case Eigenschaft_
Case olNormal
EigenschaftValidieren = "Normal"
Case olPersonal
EigenschaftValidieren = "Persönlich"
Case olPrivate
EigenschaftValidieren = "Privat"
Case olConfidential
EigenschaftValidieren = "Vertraulich"
End Select 'iVertraulichkeit
End Select 'Typ_
End 

Function 'DatumValidieren
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _


Sub OutlookAufgabenExportieren()
Dim a As Integer
Dim e As Variant
Dim tiAufgabe As TaskItem
Dim bExcelGeoeffnet As Boolean
Dim rExcelRange As Excel.Range
With ActiveExplorer.CurrentFolder
If (.Items.Count > 0) And (True) Then
Ueberschriften = Array( _
"Betreff", _
"Text", _
"Angelegt", _
"Modifiziert", _
"Serie", _
"Fällig am", _
"Begonnen am", _
"Status", _
"Priorität", _
"Vertraulichkeit", _
"% erledigt", _
"Erinnerung", _
"Zuständig", _
"Erledigt am", _
"Gesamtaufwand", _
"Ist-Aufwand")
On Error Resume Next
Set appExcel = CreateObject("Excel.Application") 'Excel öffnen
appExcel.Visible = True
Set wbExcel = appExcel.Workbooks.Add             'neue Arbeitsmappe anlegen
If wbExcel.Worksheets.Count > 0 Then
Set wsExcel = wbExcel.Worksheets(1)          'erste Tabelle auswählen bzw. ...
Else
Set wsExcel = wbExcel.Worksheets.Add         '... neue Tabelle anlegen
End If 'Count>0
bExcelGeoeffnet = (Err.Number = 0)
On Error GoTo 0
If bExcelGeoeffnet Then
AufgabenEigenschaftSchreiben 0, 0, 0 'Überschriften schreiben
For a = 1 To .Items.Count
On Error Resume Next
Set tiAufgabe = .Items(a)
With tiAufgabe
AufgabenEigenschaftSchreiben a, 1, .Subject 'Text
AufgabenEigenschaftSchreiben a, 2, .Body 'Text
AufgabenEigenschaftSchreiben a, 3, EigenschaftValidieren(.CreationTime, iDatum)
AufgabenEigenschaftSchreiben a, 4, EigenschaftValidieren(.LastModificationTime, iDatum)
AufgabenEigenschaftSchreiben a, 5, .IsRecurring 'Wahrheitswert
AufgabenEigenschaftSchreiben a, 6, EigenschaftValidieren(.DueDate, iDatum)
AufgabenEigenschaftSchreiben a, 7, EigenschaftValidieren(.StartDate, iDatum)
AufgabenEigenschaftSchreiben a, 8, EigenschaftValidieren(.Status, iStatus)
AufgabenEigenschaftSchreiben a, 9, EigenschaftValidieren(.Importance, iWichtigkeit)
AufgabenEigenschaftSchreiben a, 10, EigenschaftValidieren(.Sensitivity, iVertraulichkeit)
AufgabenEigenschaftSchreiben a, 11, .PercentComplete / 100 'Prozent
AufgabenEigenschaftSchreiben a, 12, EigenschaftValidieren(.ReminderTime, iDatum)
AufgabenEigenschaftSchreiben a, 13, .Owner 'Text
AufgabenEigenschaftSchreiben a, 14, EigenschaftValidieren(.DateCompleted, iDatum)
AufgabenEigenschaftSchreiben a, 15, .TotalWork 'in Minuten angegeben
AufgabenEigenschaftSchreiben a, 16, .ActualWork 'in Minuten angegeben
End With 'tiAufgabe
On Error GoTo 0
Next a
a = a - 1
Set rExcelRange = wsExcel.Range(Cells(yOffset, xOffset + 1), Cells(yOffset + a, xOffset +  _
UBound(Ueberschriften)))
With rExcelRange
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
End With 'rExcelRange
Set rExcelRange = wsExcel.Range(Cells(yOffset, xOffset + 1), Cells(yOffset, xOffset + UBound( _
Ueberschriften)))
With rExcelRange
.BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
.Interior.ColorIndex = 37
.Font.Bold = True
.Columns.AutoFit 'geht so nicht
End With 'rExcelRange
Set rExcelRange = Nothing
'Excel-Datei speichern und schließen
On Error Resume Next
wbExcel.SaveAs ExcelDateiname
Application.ActiveExplorer.Activate
If Err.Number = 0 Then
MsgBox "Die Datei """ & wbExcel.FullName & """ wurde gespeichert.", vbInformation, "Erfolgreich" _
Else
MsgBox "Die Datei """ & wbExcel.FullName & """ konnte nicht gespeichert werden.", vbCritical, " _
Fehler"
End If 'Err=0
On Error GoTo 0
wbExcel.Close False
'Excel beenden
'appExcel.Quit
'Das machen wir hier nicht. Wenn Excel nämlich schon offen war,
'soll es auch offen bleiben. Falls nicht, wird es bei "Nothing"
'automatisch geschlossen (s.u.).
Else
MsgBox "Excel konnte nicht geöffnet werden!", vbCritical, "Fehler"
End If 'bExcelGeoeffnet
Else
MsgBox "Im aktuellen Outlook-Ordner liegen keine Aufgaben-Elemente vor!", vbCritical, "Fehler"
End If '.Items.Count>0
End With 'ActiveExplorer.CurrentFolder
Set wsExcel = Nothing
Set wbExcel = Nothing
Set appExcel = Nothing
End 

Sub 'OutlookAufgabenExportieren