Option Explicit

'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=111546&TITLE_SEO=111546-izmenenie-razmera-diapazona&MID=926334#message926334
Sub jjj_transpose_data_rows_to_single_column()
    On Error GoTo err_handler
    ' - -
    Dim rngTmp As Range, rngRow As Range, rngSrc As Range: Set rngSrc = ActiveSheet.UsedRange
    Dim lColMax&: lColMax = Columns.CountLarge
    Dim arrOut(): ReDim arrOut(1 To Rows.Count, 1 To 1)
    Dim i&, n&, lCnt&: lCnt = 0
    Dim arrTmp()
    
    For Each rngRow In rngSrc.Rows
        Set rngTmp = Range(rngRow.Cells(1), rngRow.EntireRow.Cells(lColMax).End(xlToLeft))
        If WorksheetFunction.CountA(rngTmp) > 0 Then
            arrTmp = uds_rng_to_arr2D(rngTmp)
            For i = 1 To UBound(arrTmp, 2)
                If Len(arrTmp(1, i)) > 0 Then
                    lCnt = lCnt + 1
                    arrOut(lCnt, 1) = arrTmp(1, i)
                End If
            Next i
        End If
    Next rngRow
    
    With Workbooks.Add
        With .Worksheets(1)
            .Cells(1, 1).Resize(lCnt).Value = arrOut
        End With
    End With
    ' - -
    On Error GoTo 0
err_handler:
    If Err <> 0 Then MsgBox Err.Number & " - " & Err.Description, vbCritical Else Debug.Print "Ladno!"
End Sub 'jjj_transpose_data_rows_to_single_column

Function uds_rng_to_arr2D(rngIn As Range)
    Dim arr()
    With rngIn
        If .Rows.CountLarge = 1 And .Columns.CountLarge = 1 Then
            ReDim arr(1 To 1, 1 To 1): arr(1, 1) = .Value
        Else
            arr = .Value
        End If
    End With
    uds_rng_to_arr2D = arr
End Function 'uds_rng_to_arr2D