VBA Excel Zellen anders anordnen

Hallo alle zusammen,

Ich bin dabei eine Excel Tabelle zu programmieren und benötige etwas Hilfe.
Ich habe folgendes Tabellenblatt (Sheet1) :



Spalte A bis K kommen aus einer Datenbankabfrage, jetzt müssen diese nurnoch durch ein Makro anders angeordnet werden.

So sollte es aussehen (Sheet2):


Ich habe bereits ein Makro, welches mir die Zeiten in 2 Spalten untereinander einfügt, jedoch besteht noch das Problem dass dort keine leerzeilen berücksichtigt werden und alles aus der Tabelle runter geschrieben wird. Außerdem bekomme ich keine Namenszuordnung hin, da in manchen Fällen der Vor- oder Nachname gleich sind, trotz anderer Nummer.
Der Name und das Datum müssen so oft runter kopiert werden wie Zeiten einer Person zugeordnet sind /2 (Da es in 2 Spalten aufgelistet werden soll).


mit folgendem Skript arbeite ich:

Sub ConsolidateIn2Columns()
Dim r As Range, pos As Integer, rowCurrent As Long, c As Integer, wsSource As Worksheet, wsDest As Worksheet
pos = 3
' source sheet
Set wsSource = Sheets("Sheet1")
' destination sheet
Set wsDest = Sheets("Sheet2")
' get next free row in sheet 2
rowCurrent = wsDest.Cells(Rows.Count, "A").End(xlUp).Row
With wsSource
' for each row in sheets 1
For Each r In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
' for 1 to last non empty column in row
For c = 1 To .Cells(r.Row, Columns.Count).End(xlToLeft).Column
' if cell is non empty
If .Cells(r.Row, c).Value <> "" Then
' copy value to destination sheet
.Cells(r.Row, c).Copy Destination:=wsDest.Cells(rowCurrent, pos)
' set column for next value
pos = IIf(pos = 3, 4, 3)
' increment row counter
If pos = 3 Then rowCurrent = rowCurrent + 1
End If
Next
Next
End With
End Sub

Sub SplitTimes()
    Dim wsSource As Worksheet, wsDest As Worksheet, colTimeStart As Integer, cell As Range, maxTimeCol As Integer, c As Integer, tmStart As Variant, tmEnd As Variant
    Set wsSource = Sheets("Sheet1")  
    Set wsDest = Sheets("Sheet2")  
    colTimeStart = 5
    With wsSource
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            If cell.Value <> "" Then  
                maxTimeCol = .Cells(cell.Row, Columns.Count).End(xlToLeft).Column
                If maxTimeCol >= colTimeStart Then
                    For c = colTimeStart To maxTimeCol Step 2
                        tmStart = .Cells(cell.Row, c).Value
                        tmEnd = .Cells(cell.Row, c + 1).Value
                        If tmEnd = "" Then  
                            colTimeStart = 6
                            tmEnd = cell.Offset(1, 4).Value
                        Else
                            colTimeStart = 5
                        End If
                        wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 6).Value = Array(cell.Value, cell.Offset(0, 1).Value, cell.Offset(0, 2).Value, cell.Offset(0, 3).Value, tmStart, tmEnd)  
                    Next
                Else
                    cell.Resize(1, 4).Copy Destination:=wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
                End If
            End If
        Next
    End With
End Sub