ICS Import zu Excel
Falls es jemanden interessiert.
Auf Grundlage einer gefundenen Anleitung habe ich mal ein Makro (VBA) für Excel angepasst, welches iCal-Dateien (ICS-Format) direkt in eine Excel-Tabelle einlesen kann.
Der Code könnte vielleicht noch etwas optimiert werden (wiederkehrende Befehlszeilen) aber es funktioniert erstmal.
Mit der SplitDate-Routine werden nur noch die DTSTART und DTEND Werte zum leichteren Editieren aufgeteilt.
Kann man manuell oder bei Bedarf auch automatisch ausführen.
Ein Export-Funktion hätte ich auch anzubieten, die müßte aber noch an diese Tabelle angepasst werden.
Viel Vergnügen damit
PS: Ist nur teilweise mein Knowhow, hoffe es erfüllt die Voraussetzung zum Veröffentlichen.
Auf Grundlage einer gefundenen Anleitung habe ich mal ein Makro (VBA) für Excel angepasst, welches iCal-Dateien (ICS-Format) direkt in eine Excel-Tabelle einlesen kann.
Der Code könnte vielleicht noch etwas optimiert werden (wiederkehrende Befehlszeilen) aber es funktioniert erstmal.
Sub ICS_Import()
' modifiziert nach: https://www.experts-exchange.com/questions/26193790/Importing-Calendar-files-into-Excel-ics-xls.html
' This version require a reference to a "Microsoft ActiveX Data Objects"
Dim filename As String
filename = Application.GetOpenFilename("Calendar Files (*.ics),*.ics")
If filename = "False" Then Exit Sub
Dim objStream, strData
Dim r As Long, c As Long, line As String, dtStr As String, aStr As String, mlValue As String, dtArr() As String
Dim colNames As Variant
colNames = Array("DTSTART", "DTEND", "DTSTAMP", "UID", "CREATED", "DESCRIPTION", "RRULE", "LAST-MODIFIED", "LOCATION", "SEQUENCE", "STATUS", "SUMMARY", "TRANSP")
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "utf-8"
objStream.Open
objStream.Type = adTypeText
objStream.LoadFromFile (filename)
c = 0
For c = 0 To 12
Cells(1, c + 1).Value = colNames(c)
Next c
r = 2
line = objStream.ReadText(adReadLine)
Do Until objStream.EOS
If Left(line, 1) <> Chr(9) Then
aStr = Split(line, ":")(0)
End If
Select Case True
Case Left(line, 7) = "DTSTART"
dtStr = Replace(line, aStr & ":", "")
Cells(r, 1).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Cells(r, 1) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm:ss")
Case Left(line, 5) = "DTEND"
dtStr = Replace(line, aStr & ":", "")
Cells(r, 2).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Cells(r, 2) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm:ss")
Case Left(line, 7) = "DTSTAMP"
dtStr = Replace(line, aStr & ":", "")
Cells(r, 3).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Cells(r, 3) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm:ss")
Case Left(line, 3) = "UID"
Cells(r, 4) = Replace(line, aStr & ":", "")
Case Left(line, 7) = "CREATED"
dtStr = Replace(line, aStr & ":", "")
Cells(r, 5).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Cells(r, 5) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm:ss")
Case Left(line, 11) = "DESCRIPTION"
Cells(r, 6) = Replace(line, aStr & ":", "")
Case Left(line, 5) = "RRULE"
Cells(r, 7) = Replace(line, aStr & ":", "")
Case Left(line, 13) = "LAST-MODIFIED"
dtStr = Replace(line, aStr & ":", "")
Cells(r, 8).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Cells(r, 8) = Format(ParseDateZ(dtStr), "yyyy-mm-dd hh:mm:ss")
Case Left(line, 8) = "LOCATION"
Cells(r, 9) = Replace(line, aStr & ":", "")
Case Left(line, 8) = "SEQUENCE"
Cells(r, 10) = Replace(line, aStr & ":", "")
Case Left(line, 6) = "STATUS"
Cells(r, 11) = Replace(line, aStr & ":", "")
Case Left(line, 7) = "SUMMARY"
Cells(r, 12) = Replace(line, aStr & ":", "")
Case Left(line, 6) = "TRANSP"
Cells(r, 13) = Replace(line, aStr & ":", "")
Case Left(line, 10) = "END:VEVENT"
r = r + 1
End Select
line = objStream.ReadText(adReadLine)
Loop
Dim Spalte As Range
For Each Spalte In ActiveSheet.UsedRange.Columns
Spalte.AutoFit
Next Spalte
End Sub
Function ParseDateZ(dtStr As String)
Dim dtArr() As String
Dim dt As Date
dtArr = Split(Replace(dtStr, "Z", ""), "T")
dt = DateSerial(Left(dtArr(0), 4), Mid(dtArr(0), 5, 2), Right(dtArr(0), 2))
If UBound(dtArr) > 1 Then
dt = dt + TimeSerial(Left(dtArr(1), 2), Mid(dtArr(1), 3, 2), Right(dtArr(1), 2))
End If
ParseDateZ = dt
End Function
Sub SplitDate()
Dim LastRow, i
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Columns("B").Insert Shift:=xlToRight
Columns("D").Insert Shift:=xlToRight
Cells(1, 2).Value = "TIMESTART"
Cells(1, 4).Value = "TIMEEND"
For i = 2 To LastRow
Cells(i, 2) = Cells(i, 1)
Cells(i, 4) = Cells(i, 3)
Columns("A").NumberFormat = "dd.mm.yyyy"
Columns("B").NumberFormat = "hh:mm:ss"
Columns("C").NumberFormat = "dd.mm.yyyy"
Columns("D").NumberFormat = "hh:mm:ss"
Next
End Sub
Mit der SplitDate-Routine werden nur noch die DTSTART und DTEND Werte zum leichteren Editieren aufgeteilt.
Kann man manuell oder bei Bedarf auch automatisch ausführen.
Ein Export-Funktion hätte ich auch anzubieten, die müßte aber noch an diese Tabelle angepasst werden.
Viel Vergnügen damit
PS: Ist nur teilweise mein Knowhow, hoffe es erfüllt die Voraussetzung zum Veröffentlichen.
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-Key: 379164
Url: https://administrator.de/contentid/379164
Ausgedruckt am: 29.03.2024 um 14:03 Uhr
9 Kommentare
Neuester Kommentar
Ich habe von Schulferien org. eine ics für Ferientermine runtergeladen und wollte die mit Deinem Makro in Excel importieren…
Der erste Stopp kam bei : objStream.Type = adTypeText
Als ich den gelöscht habe blieb ich stecken bei: aStr = Split(line, ":")(0)
Kannst Du Dein Makro bitte noch verbessern? So funktioniert es leider nicht.
Sorry ich schrieb gerad unter dem falschen Makro
Der erste Stopp kam bei : objStream.Type = adTypeText
Als ich den gelöscht habe blieb ich stecken bei: aStr = Split(line, ":")(0)
Kannst Du Dein Makro bitte noch verbessern? So funktioniert es leider nicht.
Sorry ich schrieb gerad unter dem falschen Makro
Ich habe von Schulferien org. eine ics für Ferientermine runtergeladen und wollte die mit Deinem Makro in Excel importieren…
Der erste Stopp kam bei : objStream.Type = adTypeText
Als ich den gelöscht habe blieb ich stecken bei: aStr = Split(line, ":")(0)
Kannst Du Dein Makro bitte noch verbessern? So funktioniert es leider nicht.
Der erste Stopp kam bei : objStream.Type = adTypeText
Als ich den gelöscht habe blieb ich stecken bei: aStr = Split(line, ":")(0)
Kannst Du Dein Makro bitte noch verbessern? So funktioniert es leider nicht.