Sub u_736()
    Application.ScreenUpdating = False
    '..................................................................................
    aa = 5                    'левый столбец ТН
    ab = Cells(1, Columns.Count).End(xlToLeft).Column   'правый столбец ТН
    ba = 2                    'верхняя строка МНН
    bb = Cells(Rows.Count, "b").End(xlUp).Row           'нижняя строка МНН
    ca = "Рез"                    'имя листа выгрузки результата
    '..................................................................................
    For ea = ba To bb
        eb = Sheets(ca).Cells(Rows.Count, "b").End(xlUp).Row + 1 'строка вставки
        Range("b" & ea).Copy Sheets(ca).Range("a" & eb) '
        Range(Cells(ea, aa), Cells(ea, ab)).Copy
        Sheets(ca).Range("b" & eb).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Next
    Application.CutCopyMode = False
End Sub

Sheets(ca).Columns("a:b").Clear

Else
        'k = k + 1
        Exit For

let
    путь = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content]{0}[Путь],
    лист = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content]{0}[Лист],
    Источник = Excel.Workbook(File.Contents(путь), null, true),
    Лист1_Sheet = Источник{[Item=лист,Kind="Sheet"]}[Data],
    #"Повышенные заголовки" = Table.PromoteHeaders(Лист1_Sheet, [PromoteAllScalars=true]),
    #"Удаленные столбцы" = Table.RemoveColumns(#"Повышенные заголовки",{"Код схемы", "Наименование и описание схемы ", "КСГ"}),
    #"Другие столбцы с отмененным свертыванием" = Table.UnpivotOtherColumns(#"Удаленные столбцы", {"МНН"}, "Атрибут", "Значение"),
    #"Удаленные столбцы1" = Table.RemoveColumns(#"Другие столбцы с отмененным свертыванием",{"Атрибут"})
in
    #"Удаленные столбцы1"

Sub transpNew()

  Dim sh As Worksheet
  Dim iCols As Integer, iRows As Integer
  Dim aValues As Variant, aRep() As Variant
  Dim i As Integer, j As Integer, iCurr As Integer, sKey As String
  
  iCurr = 1
  sKey = ""
  Set sh = ThisWorkbook.Worksheets("Лист1")

  iCols = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
                            
  iRows = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
  sh.Select
  aValues = sh.Range(sh.Cells(1, 1), sh.Cells(iRows, iCols)).Value
  ReDim aRep(1 To iRows * iCols, 1 To 2)
  For i = LBound(aValues) + 1 To UBound(aValues)
    sKey = aValues(i, 2)
    For j = 5 To UBound(aValues, 2)
      If Not IsEmpty(aValues(i, j)) Then
        aRep(iCurr, 1) = sKey
        aRep(iCurr, 2) = aValues(i, j)
        sKey = ""
        iCurr = iCurr + 1
      End If
    Next j
  Next i
  ReDim aValues(0 To iCurr - 1, 1 To 2)
  aValues(0, 1) = "MHH"
  aValues(0, 2) = "TH"
  For i = LBound(aValues) + 1 To UBound(aValues)
    aValues(i, 1) = aRep(i, 1)
    aValues(i, 2) = aRep(i, 2)
  Next i
  With ThisWorkbook.Worksheets("Результат")
    .UsedRange.Clear
    .Range("A1").Resize(UBound(aValues, 1), UBound(aValues, 2)).Value = aValues
    .Select
  End With
  
End Sub