Sub t48()
    Dim lngI As Long
    Dim lngJ As Long
    Dim lngK As Long
    Dim whIn As Worksheet
    Dim whOut As Worksheet
        Set whIn = Worksheets("Исходные")
        Set whOut = Worksheets("Результат")
        whOut.UsedRange.Clear
        lngK = 1
            With whIn
                For lngI = 1 To .UsedRange.Columns.Count
                    For lngJ = 1 To .UsedRange.Rows.Count
                        If .Cells(lngJ, lngI) <> "" Then
                            whOut.Cells(lngK, 1) = .Cells(lngJ, lngI)
                            lngK = lngK + 1
                        End If
                Next lngJ
                Next lngI
            End With
        Set whIn = Nothing
        Set whOut = Nothing
End Sub