Option Explicit

Sub Транспонировать_выделенный()
    If TypeName(Selection) <> "Range" Then Exit Sub
    Transponse_range Selection, Selection.Cells(1, 5)
End Sub

Private Sub Transponse_range(rSource As Range, rTarget As Range)
    On Error Resume Next
    Set rSource = Intersect(rSource.Columns(1).EntireColumn, rSource)
    Set rSource = Intersect(rSource, rSource.Parent.UsedRange)
    On Error GoTo 0
    If rSource Is Nothing Then Exit Sub
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    FillDicFromRange rSource, dic
    If dic.Count = 0 Then Exit Sub
    EditDic dic
    
    ClearTargetRange rSource, rTarget, GetColumnsCount(dic)
    PrintDic dic, rTarget
End Sub
    
Private Sub PrintDic(dic As Object, rTarget As Range)
    Dim trr As Variant
    ReDim trr(1 To dic.Count, 1 To 2 + GetColumnsCount(dic))
    
    Dim yt As Long, xt As Long, xs As Long, nrr As Variant
    For yt = 1 To UBound(trr, 1)
        nrr = Split(dic.Keys()(yt - 1), "#")
        trr(yt, 1) = nrr(0)
        trr(yt, 2) = nrr(1)
        
        xt = 2
        nrr = dic.Items()(yt - 1)
        For xs = LBound(nrr) + 1 To UBound(nrr)
            xt = xt + 1
            trr(yt, xt) = nrr(xs)
        Next
    Next
    
    rTarget.Resize(UBound(trr, 1), UBound(trr, 2)).Value = trr
End Sub
    
Private Function GetColumnsCount(dic As Object) As Long
    Dim nn As Long
    Dim vKey As Variant
    For Each vKey In dic.Keys
        nn = UBound(dic(vKey))
        If GetColumnsCount < nn Then GetColumnsCount = nn
    Next
End Function
    
Private Sub EditDic(dic As Object)
    Dim vKey As Variant
    For Each vKey In dic.Keys
        dic(vKey) = Split(dic(vKey), " ")
    Next
End Sub
    
Private Sub FillDicFromRange(rSource As Range, dic As Object)
    Dim rArea As Range, arr As Variant
    For Each rArea In rSource.Areas
        arr = rArea.Resize(, 3).Value
        FillDicFromArray arr, dic
    Next
End Sub

Private Sub FillDicFromArray(arr As Variant, dic As Object)
    Dim ya As Long, xa As Long, sKey As String
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then GoTo bad_row
            If IsEmpty(arr(ya, xa)) Then GoTo bad_row
        Next
        If Not arr(ya, 3) Like "#:##:##" Then GoTo bad_row
        sKey = arr(ya, 1) & "#" & arr(ya, 2)
        dic(sKey) = dic(sKey) & " " & arr(ya, 3)
bad_row:
    Next
End Sub

Private Sub ClearTargetRange(rSource As Range, rTarget As Range, columnsCount As Long)
    Dim rEnd As Range
    Set rEnd = rTarget.Cells(1)
    
    Dim rArea As Range
    For Each rArea In rSource.Areas
        Set rArea = rArea.Cells(rArea.Rows.Count, rArea.Columns.Count)
        If rEnd.Row < rArea.Row Then
            Set rEnd = Intersect(rEnd.EntireColumn, rArea.EntireRow)
        End If
    Next
    
    rTarget.Parent.Range(rTarget.Cells(1), rEnd).Resize(, columnsCount).ClearContents
End Sub