Option Explicit

Sub jjj()
    Dim arrDebitor(), arrHeads(), arrData(), i&, j&, n&, lRowsTotal&, lColsTotal&, lCnt&, arrNewHeads(), arrResult()
    arrDebitor = [A5:A28].Value
    arrHeads = [B4:D4].Value
    With Intersect([A5:A28].EntireRow, [B4:D4].EntireColumn)
        arrData = .Value
        lRowsTotal = .Rows.CountLarge
        n = .Columns.CountLarge
    End With 'Intersect([A5:A28].EntireRow, [B4:D4].EntireColumn)
    arrNewHeads = VBA.Array("Дебитор", "Attribute", "Value")
    lColsTotal = UBound(arrNewHeads, 1) - LBound(arrNewHeads, 1) + 1
    ReDim arrResult(1 To n * lRowsTotal, 1 To lColsTotal)
    lCnt = 0
    For i = 1 To lRowsTotal
        For j = 1 To n
            If IsNumeric(arrData(i, j)) Then
                lCnt = lCnt + 1
                arrResult(lCnt, 1) = arrDebitor(i, 1)
                arrResult(lCnt, 2) = arrHeads(1, j)
                arrResult(lCnt, 3) = arrData(i, j)
            End If 'IsNumeric(arrData(i, j))
        Next j
    Next i
    If lCnt > 0 Then
        With Workbooks.Add.Sheets(1)
            .Cells(1, 1).Resize(, lColsTotal).Value = arrNewHeads
            .Cells(2, 1).Resize(lCnt, lColsTotal).Value = arrResult
        End With 'Workbooks.Add.Sheets(1)
    End If 'lCnt > 0
End Sub

Sub Транспонировать()
    Dim arrSrc(), arrRes()
    Dim r As Long, i As Long, j As Long
    
    arrSrc() = Range("A1").CurrentRegion.Value
    ReDim arrRes(1 To UBound(arrSrc, 1) * UBound(arrSrc, 2), 1 To 3)
    For i = 2 To UBound(arrSrc, 1)
        For j = 2 To UBound(arrSrc, 2)
            If arrSrc(i, j) <> "" Then
                r = r + 1
                arrRes(r, 1) = arrSrc(i, 1)
                arrRes(r, 2) = arrSrc(1, j)
                arrRes(r, 3) = arrSrc(i, j)
            End If
        Next j
    Next i
    Worksheets.Add After:=ActiveSheet
    Range("A1:C1").Value = Array("Дебитор", "Attribute", "Value")
    Range("A2").Resize(UBound(arrRes, 1), UBound(arrRes, 2)).Value = arrRes()
End Sub