Sub Макрос1()
Dim arr, arr1, n As Long, m As Long, k As Long
On Error GoTo Osh
arr = Range("C6:J" & Cells(Rows.Count, 3).End(xlUp).Row).Value
k = 1
For n = LBound(arr) To UBound(arr) Step 2
    For m = LBound(arr, 2) + 2 To UBound(arr, 2)
        If arr(n, m) <> "" Or arr(n + 1, m) <> "" Then
            k = k + 1
        End If
    Next
Next
ReDim arr1(1 To k, 1 To 3)
k = 1
For n = LBound(arr) To UBound(arr) Step 2
    For m = LBound(arr, 2) + 2 To UBound(arr, 2)
        If arr(n, m) <> "" Or arr(n + 1, m) <> "" Then
            arr1(k, 1) = arr(n + 1, 1)
            arr1(k, 2) = arr(n + 1, m)
            arr1(k, 3) = arr(n, m)
            k = k + 1
        End If
    Next
Next
Range("M6").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
Exit Sub
Osh:
    MsgBox "Ошибка данных"
End Sub

let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    Заполнить = Table.FillUp(Источник,{"Имя"}),
    Удалить_столбцы = Table.Buffer(Table.SelectColumns(Заполнить,{"Имя", "СТ", "СТ3", "СТ4", "СТ5", "СТ6", "ПР"})),
    Группа = Table.Group(
       Удалить_столбцы,
        "Имя",     
        {{
              "Количество",
              (t) =>
              [
                c = Table.RemoveColumns(t,"Имя"),
                s = Table.ToColumns(c),
                b = List.Split(List.Combine(s),2),
                d = Table.FromRows(b,{"Код","Час"}),
                e = Table.SelectRows(d, each [Час] <> null or [Код] <> null)
              ] [e]
        }}),
    Развернуть = Table.ExpandTableColumn(Группа, "Количество", {"Час", "Код"}, {"Час", "Код"})
in
    Развернуть