Sub Trans()
    Dim rngHor As Range
    Dim rngVer As Range
    Dim rngOut As Range
    Dim counter As Long
    Dim lngRow As Long
    Dim cell As Range
 
    Set rngHor = Application.InputBox("Enter Data range", Type:=8)
    Set rngVer = Application.InputBox("Enter Vertical range", Type:=8)
    Set rngOut = Application.InputBox("Enter Output range", Type:=8)
 
    For Each cell In rngVer
        DoEvents
        rngOut(counter + 1, 1).Resize(rngHor.Columns.Count, 1).Value2 = cell
        rngOut(counter + 1, 2).Resize(rngHor.Columns.Count, 1).Value2 = WorksheetFunction.Transpose(rngHor.Rows(lngRow + 1))
        lngRow = lngRow + 1
        counter = counter + rngHor.Columns.Count
    Next
    
    Const lCol As Long = 2 'Номер слобца,где ищем пустые ячейки
    Const lFirstRow As Long = 1 'Номер строки с которой начинаем отчёт
    Dim li As Long, lLastRow As Long, lCalc As Long
        With Application
        'Для ускорения выполнения Отключаем обновление экрна и пересчет формул
        .ScreenUpdating = 0: lCalc = .Calculation: .Calculation = xlManual 'идем циклом по всем ячейкам столбца lCol
            For li = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To lFirstRow Step -1
                 'Если ячейка пустая - удаляем строку.
                 If Cells(li, lCol) = "" Then Rows(li).Delete
            Next li
    'возвращаем обновление экрна и пересчет формул
     .ScreenUpdating = 1: .Calculation = lCalc
      End With
End Sub