Wie kann ich eine Excel Datei eine ics Datei kopieren?

1 Antwort

EmWald
09.01.2019, 10:14

Ich habe auf dieser Seite http://www.herber.de/forum/archiv/1224to1228/1225493_iCal_Datei_aus_Excel_erstellen_Kalender_ics.html folgendes Makro gefunden:

Sub ICS_Erstellen()

    Range("A2").Select

'Erstellt den Zeitstempel
'wird benötigt für die UID des Kalendereintrages und für die Felder
'"erstellt am" --> "DTSTAMP" und "zuletzt geändert am" --> "LAST-MODIFIED"
    Dim jahr_jetzt As String
    jahr_jetzt = Year(Now)
    Dim monat_jetzt As String * 2
    monat_jetzt = Month(Now)
    If monat_jetzt < 10 Then monat_jetzt = "0" + monat_jetzt
    Dim tag_jetzt As String * 2
    tag_jetzt = Day(Now)
    If tag_jetzt < 10 Then tag_jetzt = "0" + tag_jetzt
    Dim stunde_jetzt As String * 2
    stunde_jetzt = Hour(Now) - 1
    If stunde_jetzt < 10 Then stunde_jetzt = "0" + stunde_jetzt
    Dim minute_jetzt As String * 2
    minute_jetzt = Minute(Now)
    If minute_jetzt < 10 Then minute_jetzt = "0" + minute_jetzt
    Dim sekunde_jetzt As String * 2
    sekunde_jetzt = Second(Now)
    If sekunde_jetzt < 10 Then sekunde_jetzt = "0" + sekunde_jetzt
    zeitstempel = jahr_jetzt + monat_jetzt + tag_jetzt + "T" + stunde_jetzt + minute_jetzt +  _
sekunde_jetzt + "Z"

'Erstellt die Kalenderdatei (hier: Dpl.ics)
'Dateiname kann frei gewählt werden
'Der entsprechende Ordner MUSS vorhanden sein, da sonst ein Fehler auftritt
    Set fs = CreateObject("scripting.filesystemobject")
    Set a = fs.createtextfile("Kalender.ics",  _
True)

'Schreibt den allgemeinen Teils der Kalenderdatei
    a.writeline ("BEGIN:VCALENDAR")
    a.writeline ("VERSION:2.0")
    a.writeline ("PRODID:-//Mozilla.org/NONSGML Mozilla Calendar V1.1//EN")
    a.writeline ("METHOD:PUBLISH")
    a.writeline ("BEGIN:VTIMEZONE")
    a.writeline ("TZID:Europe/Berlin")
    a.writeline ("X-LIC-LOCATION:Europe/Berlin")
    a.writeline ("BEGIN:DAYLIGHT")
    a.writeline ("TZOFFSETFROM:+0100")
    a.writeline ("TZOFFSETTO:+0200")
    a.writeline ("TZNAME:CEST")
    a.writeline ("DTSTART:19700329T020000")
    a.writeline ("RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=3")
    a.writeline ("END:DAYLIGHT")
    a.writeline ("BEGIN:STANDARD")
    a.writeline ("TZOFFSETFROM:+0200")
    a.writeline ("TZOFFSETTO:+0100")
    a.writeline ("TZNAME:CET")
    a.writeline ("DTSTART:19701025T030000")
    a.writeline ("RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10")
    a.writeline ("END:STANDARD")
    a.writeline ("END:VTIMEZONE")

'Schleife zur Ermittlung aller Einträge
'Benutzt alle Datensätze, die ein Datum enthalten
    i = 1
    While ActiveCell.Offset(i, 0) <> ""

    Dim datstart As Date
    datstart = ActiveCell.Offset(i, 0)
    Dim timestart As Date
    timestart = ActiveCell.Offset(i, 1)
    Dim datend As Date
    datend = ActiveCell.Offset(i, 2)
    Dim timeend As Date
    timeend = ActiveCell.Offset(i, 3)
    Dim thema As String
    thema = ActiveCell.Offset(i, 4)
    Dim ort As String
    ort = ActiveCell.Offset(i, 5)
    Dim diensthabender As String
    diensthabender = ActiveCell.Offset(i, 6)
    
'Aufbereitung Datum und Zeit für Beginn
    Dim jdatstart As String
    jdatstart = Year(datstart)
    Dim mdatstart As String
    mdatstart = Month(datstart)
    If mdatstart < 10 Then mdatstart = "0" + mdatstart
    Dim tdatstart As String
    tdatstart = Day(datstart)
    If tdatstart < 10 Then tdatstart = "0" + tdatstart
    Dim hhtimestart As String
    hhtimestart = Hour(timestart)
    If hhtimestart < 10 Then hhtimestart = "0" + hhtimestart
    Dim mmtimestart As String
    mmtimestart = Minute(timestart)
    If mmtimestart < 10 Then mmtimestart = "0" + mmtimestart
    Dim sstimestart As String
    sstimestart = "00"
    
'Aufbereitung Datum und Zeit für Ende
    Dim jdatend As String
    jdatend = Year(datend)
    Dim mdatend As String
    mdatend = Month(datend)
    If mdatend < 10 Then mdatend = "0" + mdatend
    Dim tdatend As String
    tdatend = Day(datend)
    If tdatend < 10 Then tdatend = "0" + tdatend
    Dim hhtimeend As String
    hhtimeend = Hour(timeend)
    If hhtimeend < 10 Then hhtimeend = "0" + hhtimeend
    Dim mmtimeend As String
    mmtimeend = Minute(timeend)
    If mmtimeend < 10 Then mmtimeend = "0" + mmtimeend
    Dim sstimeend As String
    sstimeend = "00"

   
    
Dim k As String
    k = i

'Schreibt den Kalendereintrag
'k ist ein durchlaufender Zähler
    a.writeline ("BEGIN:VEVENT")
    a.writeline ("UID:" + zeitstempel + "-@Verein-" + k)
    a.writeline ("CLASS:PUBLIC")
    a.writeline ("SUMMARY:" + thema)
    a.writeline ("DESCRIPTION:" + "Diensthabender: " + diensthabender)
    a.writeline ("LOCATION:" + ort)
    a.writeline ("DTSTART;TZID=Europe/Berlin:" + jdatstart + mdatstart + tdatstart + "T" +  _
hhtimestart + mmtimestart + sstimestart + "Z")
    a.writeline ("DTEND;TZID=Europe/Berlin:" + jdatend + mdatend + tdatend + "T" + hhtimeend +  _
mmtimeend + sstimeend + "Z")
    a.writeline ("DTSTAMP:" + zeitstempel)
    a.writeline ("LAST-MODIFIED:" + zeitstempel)
    a.writeline ("BEGIN:VALARM")
    a.writeline ("ACTION:DISPLAY")
    a.writeline ("TRIGGER;VALUE=DURATION:-P1D")
    a.writeline ("DESCRIPTION:Mozilla Alarm: " + thema)
    a.writeline ("END:VALARM")
    a.writeline ("END:VEVENT")
    
    i = i + 1
    Wend
'Ende der Schleife
    
'Ende der Kalenderdatei
    a.writeline ("END:VCALENDAR")

End Sub

Ich habe im Vergleich zum Original den Pfad der Datei geändert in dieser Zeile, kannst du beliebig anpassen, also statt "Kalender.ics" ginge auch "C:\test\Kalender.ics" oder wo die Datei gespeichert werden soll.

Set a = fs.createtextfile("Kalender.ics"

Dann muss deine Excel Datei wie folgt aufgebaut sein:

  • Spalte A: Startdatum des Termins
  • Spalte B: Startzeit des Termins
  • Spalte C: Enddatum des Termins
  • Spalte D: Endzeit des Termins
  • Spalte E: Bezeichnung des Termins
  • Spalte F: Ort des Termins
  • Spalte G: Beschreibung des Termins

Ich würde die Datei genauso aufbauen und Überflüssiges freilassen. Das Makro musst du in den VBA Editor kopieren und dann ausführen. Ich habe es jetzt nicht testen können, sollte aber funktionieren. Wenn es Probleme gibt, nochmal melden ;-)