Sub Запуск1()

    Dim shSrc As Worksheet, shRes As Worksheet, arrSrc(), dicDates As Object, dic As Object
    Dim lr As Long, lc As Long, var, r As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    lc = shSrc.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    Set dicDates = CreateObject("Scripting.Dictionary")
    
    For i = 2 To UBound(arrSrc, 1)
        For j = 3 To UBound(arrSrc, 2)
            If IsEmpty(arrSrc(i, j)) = False Then
                If dicDates.Exists(arrSrc(i, j)) = False Then
                    dicDates.Add arrSrc(i, j), ""
                End If
            End If
        Next
    Next
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For Each var In dicDates.Keys
        dic.RemoveAll
        For i = 2 To UBound(arrSrc, 1)
            For j = 3 To UBound(arrSrc, 2)
                If arrSrc(i, j) = var Then
                    dic.Add arrSrc(i, 1), ""
                    Exit For
                End If
            Next
        Next
        If dic.Count > 0 Then
            r = r + 1
            shRes.Cells(r, "A").Value = var
            shRes.Cells(r, "B").Resize(1, dic.Count).Value = dic.Keys
        End If
    Next

    shRes.Sort.SortFields.Clear
    shRes.Sort.SortFields.Add Key:=shRes.Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
    With shRes.Sort
        .SetRange shRes.Range("A1").CurrentRegion
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    shRes.Columns("A").AutoFit
    
    Application.ScreenUpdating = True
    
End Sub