Outlook Kalendereinträge in Excel formatiert einfügen

[grays]

Hallo Liebe Community,

ich bin gerade dabei mir VBA anzueignen und stoße immer wieder auf Fragen, bei denen mir einige Beiträge schon sehr geholfen haben, allerdings finde ich nichts zu meinem aktuellen Problem.

Ich versuche die Titel meiner Outlook Termine mit dem jeweiligen Datum in Excel einzufügen. Das klappt bisher auch, allerdings möchte ich, dass die Termine, die am gleichen Tag stattfinden, in eine Zelle eingefügt werden und mit "||" getrennt werden.
Der Benutzer soll über "InputBox" das Anfangs und Enddatum der Termin Ausgabe angeben können.

Kann mir hier einer weiterhelfen bzw. ist das mit VBA überhaupt umsetzbar?

Über jeden ratschlag würde ich mich mega freuen .

Liebe Grüße
Ray

 

[Yaslaw]

Alle Termine nach Datum/Zeit sorteieren, dann durchgehen. Immer das Datum merken und mit dem nächsten vergleichen. Solange es dasselbe Datum ist, zusammenhängen.
Ich hab grad keine Ahnung wie die Termienobjekte aussehen. Aber das folgende ist mal ein theoretischer Code

Dim appointments	As Object
Dim appointment 	As Object
Dim titles()		As String
Dim lastDate		As Date
Dim fieldValue		As String

appointments = outlook.appointments
'TODO: appointments() sortieren

'Um eine Null-Fehler zu vermeiden das Startdatum weit in die Zukunft setzen
lastDate = #2099-01-01#

ForEach appointment in appointments
	'Neuer Tag: Array leeren
	If appointment.date <> lastDate Then Erase titles	
	
	'Titel dem Array hinzufügen
	pushArray titles, appointment.titel
	
	'Wenn das Datum grösser als das letzte ist, hat ein neuer Tag begonnen
	If appointment.date > lastDate Then
		'Feldinhalt zusammesetzen
		fieldValue = join(titles, "||")
		'Todo: fieldValue in die passnede Zelle schreiben
	End If

	'Letztes Datum merken
	lastDate = appointment.date
Next appointment
'Letzter Tag noch abhandeln
fieldValue = join(titles, "||")
'Todo: fieldValue in die passnede Zelle schreiben





'   /**
'    * pushArray
'    * add Value to the Array
'    * @param   Array
'    * @param   Value
'    * @return  Ubound of the Array
'    */
Public Function pushArray(ByRef ioArray As Variant, ByRef iItem As Variant) As Long
    Dim nextI   As Long
 
    On Error Resume Next:
    ReDim Preserve ioArray(UBound(ioArray) + 1)
    If Err.Number <> 0 Then
        ReDim ioArray(0)
        Err.clear
    End If
    On Error GoTo 0
    If IsObject(iItem) Then
        Set ioArray(UBound(ioArray)) = iItem
    Else
        ioArray(UBound(ioArray)) = iItem
    End If
    pushArray = UBound(ioArray)
End Sub

 

[grays]

Alle Termine nach Datum/Zeit sorteieren, dann durchgehen. Immer das Datum merken und mit dem nächsten vergleichen. Solange es dasselbe Datum ist, zusammenhängen.
Ich hab grad keine Ahnung wie die Termienobjekte aussehen. Aber das folgende ist mal ein theoretischer Code

Dim appointments    As Object
Dim appointment     As Object
Dim titles()        As String
Dim lastDate        As Date
Dim fieldValue        As String

appointments = outlook.appointments
'TODO: appointments() sortieren

'Um eine Null-Fehler zu vermeiden das Startdatum weit in die Zukunft setzen
lastDate = #2099-01-01#

ForEach appointment in appointments
    'Neuer Tag: Array leeren
    If appointment.date <> lastDate Then Erase titles   
   
    'Titel dem Array hinzufügen
    pushArray titles, appointment.titel
   
    'Wenn das Datum grösser als das letzte ist, hat ein neuer Tag begonnen
    If temrin.date > lastDate Then
        'Feldinhalt zusammesetzen
        fieldValue = join(titles, "||")
        'Todo: fieldValue in die passnede Zelle schreiben
    End If

    'Letztes Datum merken
    lastDate = appointment.date
Next appointment
'Letzter Tag noch abhandeln
fieldValue = join(titles, "||")
'Todo: fieldValue in die passnede Zelle schreiben





'   /**
'    * pushArray
'    * add Value to the Array
'    * @param   Array
'    * @param   Value
'    * @return  Ubound of the Array
'    */
Public Function pushArray(ByRef ioArray As Variant, ByRef iItem As Variant) As Long
    Dim nextI   As Long
 
    On Error Resume Next:
    ReDim Preserve ioArray(UBound(ioArray) + 1)
    If Err.Number <> 0 Then
        ReDim ioArray(0)
        Err.clear
    End If
    On Error GoTo 0
    If IsObject(iItem) Then
        Set ioArray(UBound(ioArray)) = iItem
    Else
        ioArray(UBound(ioArray)) = iItem
    End If
    pushArray = UBound(ioArray)
End Sub

super, ich danke dir!