Sub Макрос4()
    Dim n As Integer, m As Integer, i As Integer, f As Boolean, arr1, arr2, y, st As String
    Set head = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet")
        arr1 = .Range(.Cells(1, 3), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column))
    End With
    m = 0
    For n = 1 To UBound(arr1, 2)
        st = Trim(Split(arr1(1, n), "[")(0))
        If Not head.exists(st) Then head.Add st, head.Count + 1 ' n
        If st = "Дата выхода сотрудника" Then
            For i = 2 To UBound(arr1)
                If arr1(i, n) <> "" Then m = m + 1
            Next
        End If
    Next n
    ReDim arr2(0 To m, 1 To head.Count + 1)
    i = 1
    For Each y In head
        arr2(0, i) = y: i = i + 1
    Next y
    i = 0
    For n = 2 To UBound(arr1)
        For m = 1 To UBound(arr1, 2)
            st = Trim(Split(arr1(1, m), "[")(0))
            If st = "Дата выхода сотрудника" Then
                If arr1(n, m) <> "" Then f = True: i = i + 1 Else f = False
            End If
            If f Then arr2(i, CInt(head(st))) = arr1(n, m)
        Next
    Next
    Worksheets("Лист1").Cells.Clear
    Worksheets("Лист1").Range("A1").Resize(UBound(arr2) + 1, UBound(arr2, 2)) = arr2
    Worksheets("Лист1").Activate
End Sub