Hallo Forum ich benötige Eure Hilfe bei einem für mich unlösbaren Problem.

Der VBA Code funktioniert soweit gut, es gibt nur ein Problem bei dem ich zu keiner Lösung komme und finde.

Es sollen bei den primären Bedingungen auch die Zeiten mit übernommen werden, aber

leider erscheinen die Zeiten nicht bei den primären, sondern bei den anderen.

Was muss ich wo ändern?

Danke für Eure Unterstützung.

Gruß

'*****************************************************************************************************
'* nach Auswahl vom Datum wird im Monatsplan nach diesem gesucht und aus der Spalte                  *
'* des Tages alle Einträge auf dem Blatt Vorlage eingetragen                                         *
'*****************************************************************************************************
Private Sub cbo_Tagesplanung_Change()

   Dim wsMon As Worksheet, lngC As Long, arD, arA, qq As Long
   Dim arE(), arF(), ee As Long, ff As Long, bolPr As Boolean
   Dim vDatum
   Dim lng As Long, i As Integer, wks1 As Worksheet
   Dim lnga As Long
'*****************************************************************************************************
'* Datum übernehmen auf Seite Vorlage Range = B1                                                     *
'*****************************************************************************************************
Worksheets("Vorlage").Range("B2").Value = cbo_Tagesplanung.Text

If cbo_Tagesplanung.Tag = "init" Then Exit Sub
   vDatum = cbo_Tagesplanung.Value
   If Not IsDate(vDatum) Then MsgBox "Kein Datum - Abbruch": Exit Sub

   Set wsMon = Sheets(Format(vDatum, "mmmm"))   ' Tabellenblatt mit dem Monat
   lngC = Day(vDatum) + 1                       ' Spalte mit dem Tag

   arD = wsMon.Cells(8, lngC).Resize(52)        ' Werte Spalte des Tages
   arA = wsMon.Cells(8, 1).Resize(52)           ' Werte Spalte A
   ReDim arE(1 To UBound(arD), 3)
   ReDim arF(1 To UBound(arD), 3)
   For qq = 1 To UBound(arD)
      Select Case arD(qq, 1)
         Case ""                                ' wirklich leer
         'Case " "                               ' ein Leerzeichen          ##### ?
         Case "F", "S", "N", "Alt", "AF", "AS", "T", "T1", "T2"  ' "Bedingung primär"
         ee = ee + 1
            arE(ee, 0) = arA(qq, 1)
            arE(ee, 1) = arD(qq, 1)
            bolPr = True
         Case Else
         If IsEmpty(arA(qq, 1)) And IsNumeric(arD(qq, 1)) Then
               If bolPr Then
                  arE(ee, 2) = arD(qq, 1)          ' Uhrzeit
               Else
                  arF(ff, 2) = arD(qq, 1)          ' Uhrzeit
               End If
               If qq < UBound(arA) Then
                  If IsEmpty(arA(qq + 1, 1)) And _
                     IsNumeric(arD(qq + 1, 1)) And _
                     Not IsEmpty(arD(qq + 1, 1)) Then
                     qq = qq + 1
                     If bolPr Then
                        arE(ee, 3) = arD(qq, 1)    ' Uhrzeit
                     Else
                        arF(ff, 3) = arD(qq, 1)    ' Uhrzeit
                        End If
                  End If
               End If
            Else
               ff = ff + 1                      ' Alle anderen
               arF(ff, 0) = arA(qq, 1)
               arF(ff, 1) = arD(qq, 1)
               bolPr = False
            End If
      End Select
   Next qq
   With Sheets("Vorlage")     ' Ausgabe in Blatt "Vorlage" - muss existieren
      .Range("A4:D47").ClearContents ' Säuberung der Zellen
      .Range("A50:D100").ClearContents ' Säuberung der Zellen
      .Cells(4, 1).Resize(ee, 4) = arE    ' primäre
      .Cells(50, 1).Resize(ff, 2) = arF    ' andere
      '.Cells(53, 2).Resize(ff, 2) = arF
      .Activate               ' falls Blatt Vorlage aktiv sein soll
   End With