Sub AktOutlook()
  Dim Otl As New Outlook.Application
  Dim F As Outlook.MAPIFolder, sf As MAPIFolder
  Dim z As Integer, n As Integer, sText As String, j As Integer
  Dim o As Outlook.AppointmentItem
 
  If MsgBox("Bei 'Ja' wird in Outlook im Ordner 'Kalender' der Unterordner" & _
    "'WM2006' " & vbCrLf & _
      "mit allen Spielen der WM 2006 erstellt/aktualisiert.", vbYesNo, "Outlook" & _
      "aktualisieren?") = vbNo Then Exit Sub
  'Kalender WM2006 auswählen/erstellen
  For Each sf In Otl.Session.Folders
    If sf.Name = Otl.Session.CurrentUser Then Exit For
  Next sf
  Set F = sf
  For Each sf In F.Folders
    If sf.Name = "Kalender" Then Exit For
  Next sf
  Set F = sf
  For Each sf In F.Folders
    If sf.Name = "WM2006" Then Exit For
  Next sf
  If sf Is Nothing Then
    Set sf = F.Folders.Add("WM2006", olFolderCalendar)
  End If
  'Einträge löschen
  While sf.Items.Count > 0
    sf.Items.Remove sf.Items.Count
  Wend
  'Einträge erstellen
  With ActiveWorkbook.Sheets(2)
    For z = 1 To 57 Step 8
      sText = .Cells(z, 1) & " - "
      For n = 1 To 6
        Set o = sf.Items.Add(olAppointmentItem)
        If .Cells(z + n, 6) <> "" Then
          o.Subject = sText & .Cells(z + n, 1) & " : " & .Cells(z + n, 3) & " -" & _
            "" & _
                    .Cells(z + n, 4) & " : " & .Cells(z + n, 6)
        Else
          o.Subject = sText & .Cells(z + n, 1) & " : " & .Cells(z + n, 3)
        End If
        o.Start = .Cells(z + n, 7)
        o.Location = .Cells(z + n, 8)
        o.Duration = 180
        o.ReminderSet = True
        o.ReminderMinutesBeforeStart = 60 * 15
        o.Body = "Aktualisiert: " & Now & vbCrLf
        For j = 0 To 5
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
            + j, 1) & vbTab
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
          + j, 2) & vbTab
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
          + j, 3) & vbTab
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
          + j, 4) & vbTab
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
          + j, 5) & vbTab
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
          + j, 6) & vbTab
          o.Body = o.Body & ActiveWorkbook.Sheets(3).Cells((z - 1) / 8 * 6 + 1 _
          + j, 7) & vbCrLf
        Next j
        o.Save
      Next n
    Next z
    ... usw.