Access und Excel Kalender

[Frank77]

Hallo!

Ich hab da folgendes problem
wenn ich die funktion aufruf funktioniert alles super
startet sie aber ein 2. mal da bekomme ich den
Laufzeitfehler 1004 "die methode worksheets für das objekt _Global ist fehlgeschlagen"

Markierte zeile ist:
_{.Worksheets.Add After:=Worksheets(Worksheets.Count)}

soweit so gut debugger abbrechen und excel ist im tastmanager noch aktiv
ergo: nächster aufruf geht

excel ist im tastmanager beendet
Laufzeitfehler 462

debugger abbrechen und es läuft wieder

Die vorgehensweise habe ich bei Word und bei Outlook aber bei Excel bekomm ich problemme und weis nicht warum

mdl_Pfad:
_{Public Function akt_Verz_Excel_Kalender() As String
    akt_Verz_Excel_Kalender = Environ("UserProfile") & "\Desktop\"
End Function}

mdl_Excel_Global:
<sub>Option Compare Database
Option Explicit

Private objExcel As Excel.Application
Private objExcelNew As Object
Private objExcel_Kalender As Object

Public Property Get CreateExcel() As Excel.Application
    On Error Resume Next
    Set objExcel = CreateObject("Excel.Application")
    If Err <> 0 Or objExcel Is Nothing Then
        Err = 0
        Set objExcel = CreateObject("Excel.Application")
        If Err <> 0 Or objExcel Is Nothing Then
            Beep
            MsgBox "Verbindung zu Excel kann nicht aufgebaut werden: " & _
                   Err.Description, vbOKOnly + vbCritical, "Problem:"
            Exit Property
        End If
    End If
    Set CreateExcel = objExcel
End Property


Public Function Excel_New(Show As Boolean) As Object
    On Error GoTo Err_ErrHandler
    If Not objExcel Is Nothing Then
        Set Excel_New = objExcel.Workbooks.Add
    End If
    If objExcel Is Nothing Then
        Set objExcel = CreateExcel
        objExcel.Visible = Show
        Set objExcelNew = objExcel.Workbooks.Add
    End If
    Set Excel_New = objExcelNew
Exit_ErrHandler:
    Exit Function
Err_ErrHandler:
    If Err <> 0 Then
        MsgBox "Excel konnte nicht erstellt werden. " & _
               Err.Description, vbOKOnly + vbCritical, "Problem !"
    End If
    Call ResetExcel
    Resume Exit_ErrHandler:
End Function


Public Sub CreateExcel_Kalender(jahr As String)
    Dim Monat As Integer
    Dim Tag As Integer
    Dim AnzTage As Integer
    Dim d As Date
    Set objExcel_Kalender = Excel_New(True)
    With objExcel_Kalender
        For Monat = 1 To 12
            AnzTage = DateSerial(Year(jahr), Monat + 1, 1) _
                    - DateSerial(Year(jahr), Monat, 1)
            .Worksheets.Add After:=Worksheets(Worksheets.Count)
            With ActiveSheet
                .Name = Format(DateSerial(1, Monat, 1), "mmm")
            End With
            Range("A1:AH2").Interior.ColorIndex = 40
            Range("D1:AH1").NumberFormat = "d"
            Range("D1:AH2").HorizontalAlignment = xlCenter
            Range("D2:AH2").NumberFormat = "ddd"
            For Tag = 1 To AnzTage
                With Cells(1, Tag + 3)
                    d = DateSerial(jahr, Monat, Tag)
                    .Value = d
                    If Weekday(d) = 1 Or Weekday(d) = 7 Then
                        Range(Cells(3, Tag + 3), (Cells(40, Tag + 3))).Interior.ColorIndex = 15
                    End If
                    Cells(2, Tag + 3) = d
                End With
            Next Tag
            Columns("D:AH").ColumnWidth = 3
            Cells(3, 1).Activate
            Cells(1, 1) = "ID"
            Cells(1, 2) = "Veranstaltung"
            Cells(1, 3) = "Datum"
        Next Monat
        .SaveAs akt_Verz_Excel_Kalender & "Planung" & jahr & ".xls"
    End With
    Call ResetExcel
    Exit Sub
End Sub


Public Sub ResetExcel()
    On Error Resume Next
    objExcel.Quit
    If Not objExcel Is Nothing Then
        Set objExcel = Nothing
    End If
    If Not objExcelNew Is Nothing Then
        Set objExcelNew = Nothing
    End If
    If Not objExcel_Kalender Is Nothing Then
        Set objExcel_Kalender = Nothing
    End If
End Sub</sub>

Aufruf z.B.:
_{Private Sub cmd_Excel_Planung_Click()
If Not IsNull(cbo_Jahr) Then CreateExcel_Kalender (cbo_Jahr)
End Sub}

Wäre super wenn jemand den fehler sieht

Gruß Frank

[daolix]

hallo
und immer wieder der selbe Fehler. Nachfolgende Excelobjecte müssen bei Fernsteuerung immer vom Excelobject abgeleitet werden, weil sonst Excel nicht beendet wird. Und die nicht beendete Excelinstance führt beim 2ten Aufruf zum Fehler.
Also alle ActiveIrgendwas, Range, Cells, Worksheets etc (und dat sind jetzt nicht wenige in deinem Code) vom Excelobject->Workbook ableiten.

relevante Zeilen:

Code [Auswählen] Erweitern

For Monat = 1 To 12
            AnzTage = DateSerial(Year(jahr), Monat + 1, 1) - DateSerial(Year(jahr), Monat, 1)
            With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                .Name = Format(DateSerial(1, Monat, 1), "mmm")
                .Range("A1:AH2").Interior.ColorIndex = 40
                .Range("D1:AH1").NumberFormat = "d"
                .Range("D1:AH2").HorizontalAlignment = xlCenter
                .Range("D2:AH2").NumberFormat = "ddd"
                For Tag = 1 To AnzTage
                    With .Cells(1, Tag + 3)
                        d = DateSerial(jahr, Monat, Tag)
                        .Value = d
                        If Weekday(d) = 1 Or Weekday(d) = 7 Then
                            .Range(.Cells(3, Tag + 3), (.Cells(40, Tag + 3))).Interior.ColorIndex = 15
                        End If
                        .Cells(2, Tag + 3) = d
                    End With
                Next Tag
                .Columns("D:AH").ColumnWidth = 3
                .Cells(3, 1).Activate
                .Cells(1, 1) = "ID"
                .Cells(1, 2) = "Veranstaltung"
                .Cells(1, 3) = "Datum"
            End With
        Next Monat

[Frank77]

Hallo!
erstmal danke für die hilfe!
hate ich vergessen zu erwähnen das ich die ableitung auch schon gesetzt habe
.Range und soweiter

wenn ich das mache so wie du es auch geschrieben hast dann entsteht das problem das des kalender dann nicht mehr passt aber die laufzeitfehler nicht mehr auftreten und es ja immer funzt

daher dacht ich es muss an anderer stelle liegen das problem den der karender passt ja

am beenden von excel such ich die ganze zeit schon rum

[daolix]

Verstanden hab ich jetzt nix, aba ich ahne was:

Code [Auswählen] Erweitern

For Tag = 1 To AnzTage
                    d = DateSerial(jahr, Monat, Tag)
                    .Cells(1, Tag + 3).Value = d
                    .Cells(2, Tag + 3).Value = d
                    If Weekday(d) = 1 Or Weekday(d) = 7 Then .Range(.Cells(3, Tag + 3), (.Cells(40, Tag + 3))).Interior.ColorIndex = 15
                Next Tag

Bei mir wird Excel nach erzeugung der Kals beendet.

[MaggieMay]

Hallo,

das problem das des kalender dann nicht mehr passt

daher dacht ich es muss an anderer stelle liegen das problem den der karender passt ja

was passt bzw. nicht passt, musst du wohl noch etwas genauer beschreiben.

Und was genau ist hiermit gemeint:

am beenden von excel such ich die ganze zeit schon rum

?

[Frank77]

Danke für die mühe das an zuschauen ihr 2!

wenn ich das so lasse     
^{For Tag = 1 To AnzTage
       With Cells(1, Tag + 3)
            d = DateSerial(jahr, Monat, Tag)
            .Value = d
            If Weekday(d) = 1 Or Weekday(d) = 7 Then
                Range(Cells(3, Tag + 3), (Cells(40, Tag + 3))).Interior.ColorIndex = 15
            End If
            Cells(2, Tag + 3) = d
        End With
    Next Tag}
dann sieht es aus wie auf bild richtig aber der fehler tritt auf das bei erneutem aufruf die laufzeitfehler eintreten

sind aber die punkte drin dann sieht es aus wie auf dem bild falsch
aber keine laufzeitfehler

"am beenden von excel such ich die ganze zeit schon rum"
der sub ResetExcel funzt bei Word und outlook kein thema auser bei excel auf der suche  nach dem warum war ich Maggy

Gruß Frank

[MaggieMay]

Hi,

daolix hatte bereits die richtige Ahnung, was die Markierung der Wochenenden betraf, tausche also den Code entsprechend aus.

Bei korrektem Bezug auf die Excel-Objekte dürfte sich dann auch das Schließen-Problem erübrigen.

[Frank77]

Hallo!

erst mal danke an den code von daolix das klapt prima

ich hab jetzt  die markierte zeile ausgetauscht nun läufts ohne probleme hinter einander ohne fehler den wenn Excel aktiv (.exe) dan wird die instance verwendet
war wohl der erste fehler

allerding ist des mango daran das wenn eine andere exceldatei geöfnet ist die auch geschlossen wird  wenn der code durchläuft (ist aber erst mal unwichtig)

_{Public Property Get CreateExcel() As Excel.Application
    On Error Resume Next
    Set objExcel = GetObject(, "Excel.Application")
    If Err <> 0 Or objExcel Is Nothing Then
        Err = 0
        Set objExcel = CreateObject("Excel.Application")
        If Err <> 0 Or objExcel Is Nothing Then
            Beep
            MsgBox "Verbindung zu Excel kann nicht aufgebaut werden: " & _
                   Err.Description, vbOKOnly + vbCritical, "Problem:"
            Call ResetExcel
            Exit Property
        End If
    End If
    Set CreateExcel = objExcel
End Property}

Excel wird aber nicht beendet und ist im tastmanager immer noch aktiv
egal wie ich es drehe und wende

ich beende es im taskmanager und führe die prozedur neu aus bekomme ich eine leere Exceltabele zu sehen und es passier weiter nix

wenn ich die tabelle dann von hand schliesse kommt eine fehlermeldung an der zeile

_{With .Worksheets.Add(After:=Worksheets(Worksheets.Count))}

ok ist ja klarr weil es nixmehr zum zugreifen gibt
die frage ist nur warum, weshalb und wiso hält die sache vor der zeile an
(Fehler behandlung fehlt in der prozedur die das abfängt zum testen warum)

und der witz an der sache ist starte ich dann alles neu läufts sauber durch
aber excel.exe beenden is nich warum auch immer obwohl
objExcel.Quit die tabelle schliesst

Gruß Frank

[daolix]

Hallo
das excel nicht geschlossen wird, liegt immer noch daran das du nicht alle Objecte ableitest.

wenn ich die tabelle dann von hand schliesse kommt eine fehlermeldung an der zeile

With .Worksheets.Add(After:=Worksheets(Worksheets.Count))

Diese Zeile steht aber oben so nicht in meinem geposteten Fragment.
Um es mal auf den Punkt zu bringen:

With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))

so läuft es bei mir ohne zicken durch (hab jetzt aber auch keinen Stresstest durchgeführt):

Code [Auswählen] Erweitern

Private objExcel As Excel.Application
Private objExcelNew As Object
Private objExcel_Kalender As Object
Private m_KillIfCreate As Boolean
Public Property Get CreateExcel() As Excel.Application
    On Error Resume Next
    Set objExcel = GetObject(, "Excel.Application")
    If Err <> 0 Or objExcel Is Nothing Then
        Err = 0
        Set objExcel = CreateObject("Excel.Application")
        If Err <> 0 Or objExcel Is Nothing Then
            Beep
            MsgBox "Verbindung zu Excel kann nicht aufgebaut werden: " & _
                   Err.Description, vbOKOnly + vbCritical, "Problem:"
            Exit Property
        End If
        m_KillIfCreate = True
    End If
    Set CreateExcel = objExcel
End Property
Public Function Excel_New(Show As Boolean) As Object
    On Error GoTo Err_ErrHandler
    If Not objExcel Is Nothing Then
        Set Excel_New = objExcel.Workbooks.Add
    End If
    If objExcel Is Nothing Then
        Set objExcel = CreateExcel
        objExcel.Visible = Show
        Set objExcelNew = objExcel.Workbooks.Add
    End If
    Set Excel_New = objExcelNew
Exit_ErrHandler:
    Exit Function
Err_ErrHandler:
    If Err <> 0 Then
        MsgBox "Excel konnte nicht erstellt werden. " & _
               Err.Description, vbOKOnly + vbCritical, "Problem !"
    End If
    Call ResetExcel
    Resume Exit_ErrHandler:
End Function
Public Sub CreateExcel_Kalender(jahr As String)
    Dim Monat As Integer
    Dim Tag As Integer
    Dim AnzTage As Integer
    Dim d As Date
    Dim vA()
    Set objExcel_Kalender = Excel_New(True)
    With objExcel_Kalender
        For Monat = 1 To 12
            AnzTage = DateSerial(Year(jahr), Monat + 1, 1) - DateSerial(Year(jahr), Monat, 1)
            ReDim vA(1 To 2, 1 To AnzTage + 3)
            With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                .Name = Format(DateSerial(1, Monat, 1), "mmm")
                .Range("A1:AH2").Interior.ColorIndex = 40
                .Range("D1:AH1").NumberFormat = "d"
                .Range("D1:AH2").HorizontalAlignment = xlCenter
                .Range("D2:AH2").NumberFormat = "ddd"
                For Tag = 1 To AnzTage
                    d = DateSerial(jahr, Monat, Tag)
                    vA(1, Tag + 3) = d
                    vA(2, Tag + 3) = d
                    If Weekday(d) = 1 Or Weekday(d) = 7 Then .Range(.Cells(3, Tag + 3), (.Cells(40, Tag + 3))).Interior.ColorIndex = 15
                Next Tag
                vA(1, 1) = "ID"
                vA(1, 2) = "Veranstaltung"
                vA(1, 3) = "Datum"
                .Range(.Cells(1, 1), .Cells(2, AnzTage + 3)) = vA()
                .Columns("D:AH").ColumnWidth = 3
            End With
        Next Monat
        .SaveAs akt_Verz_Excel_Kalender & "Planung" & jahr & ".xls"
        .Close
    End With
    Call ResetExcel
    Exit Sub
End Sub
Public Sub ResetExcel()
    On Error Resume Next
    If m_KillIfCreate = True Then objExcel.Quit
    m_KillIfCreate = False
    If Not objExcel Is Nothing Then
        Set objExcel = Nothing
    End If
    If Not objExcelNew Is Nothing Then
        Set objExcelNew = Nothing
    End If
    If Not objExcel_Kalender Is Nothing Then
        Set objExcel_Kalender = Nothing
    End If
End Sub

[MaggieMay]

Frank,
irgendwie scheinst du nicht zu verstehen, worum es geht...

Im Anhang vom 2.1.2015 19:14:07 Uhr sind die Excel-Referenzen OK, dort brauchst du lediglich die Passage

Code [Auswählen] Erweitern

                For Tag = 1 To AnzTage

'...

                Next Tag
gegen den Code von daolix im Beitrag vom 2.1.2015 19:39:17 Uhr auszutauschen.

[Frank77]

hallo!
erstmal vielen dank für die hilfe an euch beide!
funktioniert Super
@MaggieMay
ich bin nur Hobby pogrammierer weil ich eine eigene lösung für mich brauche dann wirds schwierig

ich hab des ganze jetzt noch erweiter

_{Public Function CreateExcel_Kalender(jahr As String, bolClose As Boolean, bolGet As Boolean) As Object
    Dim Monat As Integer
    Dim Tag As Integer
    Dim AnzTage As Integer
    Dim d As Date
    Dim vA()
    Set objExcel_Kalender = Excel_New(True)
    With objExcel_Kalender
        For Monat = 1 To 12
            AnzTage = DateSerial(Year(jahr), Monat + 1, 1) - DateSerial(Year(jahr), Monat, 1)
            ReDim vA(1 To 2, 1 To AnzTage + 3)
            With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                .Name = Format(DateSerial(1, Monat, 1), "mmm")
                .Range("A1:AH2").Interior.ColorIndex = 40
                .Range("D1:AH1").NumberFormat = "d"
                .Range("D1:AH2").HorizontalAlignment = xlCenter
                .Range("D2:AH2").NumberFormat = "ddd"
                For Tag = 1 To AnzTage
                    d = DateSerial(jahr, Monat, Tag)
                    vA(1, Tag + 3) = d
                    vA(2, Tag + 3) = d
                    If Weekday(d) = 1 Or Weekday(d) = 7 Then .Range(.Cells(3, Tag + 3), (.Cells(40, Tag + 3))).Interior.ColorIndex = 15
                Next Tag
                vA(1, 1) = "ID"
                vA(1, 2) = "Veranstaltung"
                vA(1, 3) = "Datum"
                .Range(.Cells(1, 1), .Cells(2, AnzTage + 3)) = vA()
                .Columns("D:AH").ColumnWidth = 3
            End With
        Next Monat
        .Sheets("Tabelle1").Delete
        .Sheets("Tabelle2").Delete
        .Sheets("Tabelle3").Delete
        .SaveAs akt_Verz_Excel_Kalender & "Planung - " & jahr & ".xls"
        If bolClose = True Then
            .Close
            Call ResetExcel
        End If
    End With
    Select Case bolGet
    Case True
        Set CreateExcel_Kalender = objExcel_Kalender
    Case Else
        Exit Function
    End Select
End Function}

um dann das ganz auch  noch weiter zu verwenden damit ich alles seperat benutzen kann und ich finde dann ist auch übersichtlicher
allerdings hab ich jetzt die grenze meines wissen glaub ereicht
und scheitere erst mal am schreiben in eine Zelle

ok warscheinlich bin ich auch mit dem auf bau wie ich mir des denke falsch

wenn die sache mal vertig ist sols im groben mal so aus sehn wie auf dem bild


<sub>Public Sub Excel_Kalender_Export(jahr As String)
    Dim rst As DAO.Recordset
    Dim ErsteLeereZeile As Long
    Dim objSheet As Object
    ErsteLeereZeile = 0
    Set objExcel_Kalender_Export = CreateExcel_Kalender(jahr, False, True)
    If Not objExcel_Kalender_Export Is Nothing Then
        Set rst = CurrentDb.OpenRecordset("qry_rpt_Veranstaltung_Termin_Excel", dbOpenSnapshot)
        '
        Set objSheet = objExcel_Kalender_Export.Worksheets("Jan")
        With objSheet
            .Select
            ErsteLeereZeile = .Range("A65536").End(xlUp).Row + 2
            Do Until rst.EOF

                .Cells(1, ErsteLeereZeile).Value = rst.Fields("Veranstaltung_ID")
                .Cells(2, ErsteLeereZeile).Value = rst.Fields("Veranstaltung_Name")
                .Cells(3, ErsteLeereZeile).Value = rst.Fields("Tag_Monat_Name")

                'Hier dann den datumsbereich Schwarz markieren alle werte
                ' sind in der abfrage vorhanden

                ' Nächste zeile in Excel
                ErsteLeereZeile = ErsteLeereZeile + 1
            Loop
        End With
    End If
End Sub</sub>

Gruß Frank

[daolix]

Hallo

CreateExcel_Kalender(jahr As String, bolClose As Boolean, bolGet As Boolean) As Object

Halte ich unnötigen, unübersichtlichen Eiertanz. Die Aufrufende Funktion (hier Excel_Kalender_Export) sollte die erstellten Objekte terminieren, nicht die aufgerufene.

Do Until rst.EOF

                .Cells(1, ErsteLeereZeile).Value = rst.Fields("Veranstaltung_ID")
                .Cells(2, ErsteLeereZeile).Value = rst.Fields("Veranstaltung_Name")
                .Cells(3, ErsteLeereZeile).Value = rst.Fields("Tag_Monat_Name")

                'Hier dann den datumsbereich Schwarz markieren alle werte
                ' sind in der abfrage vorhanden

                ' Nächste zeile in Excel
                ErsteLeereZeile = ErsteLeereZeile + 1
            Loop

Das ist nicht sehr efficient. Verwende besser CopyFromRecordset, oder, falls es aufgrund deiner Datenstrucktur damit nicht funktioniert, ein 2dimensionales Array welches du erst mit deinen Daten befüllst und dieses dann an Excel übergibst.

[Frank77]

Hallo!
ich dachte mir ich kann dann alles so aufrufen wie ich es brauche nur kalender oder füllen mit daten je nach bedarf  aber ich versuche zu lernen

ich hab jetz des ganze so weiter gebaut
<sub>Public Sub Excel_Kalender_Export(jahr As String)
    Dim rst As DAO.Recordset
    Dim ErsteLeereZeile As Long
    Dim objSheet As Object
    Dim intBeginn As Integer
    Dim intEnde As Integer
    Dim objPfeil As Shape

    ErsteLeereZeile = 0
    Set objExcel_Kalender_Export = CreateExcel_Kalender(jahr, False, True)
    If Not objExcel_Kalender_Export Is Nothing Then
        Set rst = CurrentDb.OpenRecordset("qry_rpt_Veranstaltung_Termin_Excel", dbOpenSnapshot)
        '
        Set objSheet = objExcel_Kalender_Export.Worksheets("Jan")
        With objSheet
            .Select
            ErsteLeereZeile = .Range("A65536").End(xlUp).Row + 2
            Do Until rst.EOF
                .Cells(ErsteLeereZeile, 1).Value = rst.Fields("Veranstaltung_ID")
                .Cells(ErsteLeereZeile, 2).Value = rst.Fields("Veranstaltung_Name")
                .Cells(ErsteLeereZeile, 3).Value = rst.Fields("Tag_Monat_Name")
                'Wagerechte linie zeichnen
                .Shapes.AddConnector(msoConnectorStraight, 1, Cells(ErsteLeereZeile, 1).Top, Cells(ErsteLeereZeile, 35).Left, Cells(ErsteLeereZeile, 1).Top).Select
                'Line Von-Bis datumsbereichzeichnen
                intBeginn = CInt(Left$(rst.Fields("Veranstaltung_Name"), 3)) + 3
                intEnde = CInt(Mid$(rst.Fields("Veranstaltung_Name"), 10, 3)) + 3
                Set objPfeil = .Shapes.AddLine(intBeginn, intBeginn, intEnde, intEnde).Name = ErsteLeereZeile
                With objPfeil
                    .Line.BeginArrowheadLength = msoArrowheadLengthMedium
                    .Line.BeginArrowheadWidth = msoArrowheadNarrow
                    .Line.BeginArrowheadStyle = msoArrowheadNone
                End With
                ErsteLeereZeile = ErsteLeereZeile + 1
                rst.MoveNext
            Loop
        End With
    End If
End Sub</sub>

in der zeile 
_{intBeginn = CInt(Left$(rst.Fields("Veranstaltung_Name"), 3)) + 3}
bekomme ich den fehler typ unverträglich ist aber als
_{Dim intBeginn As Integer}
bezeichnet und CInt macht doch den richtigen typ darauds oder

wenn ich im direktfenster eingebe bekomme ich das richtige ergebniss 17 da der 14 in spalte 17 beginnt
msgbox CInt(Left$("14.03  -  16.03", 3)) + 3

ich vermute alerding das ab hier schon das nächste problemm beginnt
ich find in den büchern und im netz wenig daszu und wenn versteh ich es nicht ganz wie ich des unsetzen soll
ich hätte des ganze auch lieber in einem bericht umgesetz aber da wirds ja noch schwerer
_{Set objPfeil = .Shapes.AddLine(intBeginn, intBeginn, intEnde, intEnde).Name = ErsteLeereZeile}

tausche ich
.Cells(1, ErsteLeereZeile).Value = rst.Fields("Veranstaltung_ID")
gegen
.Cells(ErsteLeereZeile, 1).Value = rst.Fields("Veranstaltung_ID")

schreibt es bei mir in der excel tabele untereinander sonst bebeneinander

Gruß Frank

[daolix]

in der zeile
intBeginn = CInt(Left$(rst.Fields("Veranstaltung_Name"), 3)) + 3
bekomme ich den fehler typ unverträglich ist aber als
Dim intBeginn As Integer
bezeichnet und CInt macht doch den richtigen typ darauds oder

Liegt das ggf daran daß du in Veranstaltung_Name lt. deinem Bildchen fdfdfd zu stehen (Was du spalte B zuordnest) und das Datum in Tag_Monat_Name(Spalte C) ?
evtl. klappt es ja mit
intBeginn = CInt(Left$(rst.Fields("Tag_Monat_Name"), 3)) + 3. Wobei mir hier die 3 nicht ganz klar ist. "2" sollte hier reichen.
Ich selbst würde, wenn ich es so umsetzen würde, mit bedingter Formatierung arbeiten und z.b. bei jedem Veranstaltungstag ein "x" pinseln und auf die Pfeile verzichten.

[Frank77]

Hallo! daolix
erstmal danke fürs anschauen

da hab ich wohl vor lauter wald die bäume nicht gesehen 

die idee dazu es so zumachen hatte ich durch das klassische kalender withebord  magnetstreifen hin papen und kucken
nur drucken geht schneller

das ende der linien stimmt wenn ich das so schreibe aber der anfang nicht ok knifflig wirds bei monats übergreifender darstelung aber des kann ich ja anhand des datums noch auswerten und bis ende des monats gehen und dann die seite wechseln und von 1 bis ende neu zeichnen

_{.Shapes.AddConnector(msoConnectorStraight, intBeginn, Cells(ErsteLeereZeile, intBeginn).Top, Cells(ErsteLeereZeile, intEnde).Left, Cells(ErsteLeereZeile, intEnde).Top).Select}

alle anderen varianten zeichnen stiche kreutz und quer und mit dem setzen des striches in die mitte der zelle komm ich auch nicht zurecht ich finde da auch wenig im netz und im excel vba buch

ich könnte das ganze auch in outlook ausgeben das klappt auch super nur ist das mango dabei das wenn der kalender gedruckt wird er nur eine begrenzte anzahl an terminen angezeigt   ich glaug 5 aber 20 untereinander darzustellen geht da auch nicht

ich hab das ganze in ein neues beispiel gepackt vieleicht kennst du ja die lösung 

Gruß Frank