Excel: Макрос или формула для транспонирования таблицы в один столбик

[WinterWolf]

Добрый день. Суть в том, что нужен макрос или формула, что бы всю таблицу, которая может быть неравномерной, по строкам перенести в один большой столбец

[вложение удалено администратором]

[Администратор]

Макрос

Sub Макрос()

    Dim sh As Worksheet
    Dim lr As Long, lc As Long, i As Long
   
   
    '1. Отключение монитора, чтобы ускорить макрос.
    Application.ScreenUpdating = False
   
    '2. Vba-именование активного листа, чтобы обращаться к листу по имени "sh".
    Set sh = ActiveSheet
   
    '3. Проверка, что нет скрытых строк, т.к. некоторые действия не работают, если скрыты строки.
    If sh.Rows.SpecialCells(xlCellTypeVisible).Rows.Count <> sh.Rows.Count Then
        Application.ScreenUpdating = True
        MsgBox "Отобразите все строки, чтобы не было непредвиденных ситуаций.", vbExclamation
        Exit Sub
    End If
   
    '4. Проверка, что нет скрытых столбцов, т.к. некоторые действия не работают, если скрыты столбцы.
    If sh.Columns.SpecialCells(xlCellTypeVisible).Columns.Count <> sh.Columns.Count Then
        Application.ScreenUpdating = True
        MsgBox "Отобразите все столбцы, чтобы не было непредвиденных ситуаций.", vbExclamation
        Exit Sub
    End If
   
    '5. Поиск последней строки с данными по столбцу A.
    lr = sh.Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
       
    For i = lr To 1 Step -1
   
        '6. Поиск последнего столбца в текущей строке.
        lc = sh.Rows(i).Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Column
       
        '7. Если только одна ячейка с данными, то никакие действия не надо делать.
        If lc = 1 Then
            GoTo metka_NextRow
        End If
       
        '8. Вставка нужного кол-ва пустых строк.
        sh.Rows(i + 1).Resize(lc - 1).Insert
       
        '9. Копирование данных из строки в столбец.
        sh.Cells(i, "A").Resize(lc).Value = WorksheetFunction.Transpose(sh.Cells(i, "A").Resize(, lc).Value)
       
        '10. Очистка строки.
        sh.Cells(i, "B").Resize(, lc - 1).ClearContents

metka_NextRow:
    Next i

    '11. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

[свернуть]

[WinterWolf]

Тестил весь день.
Каких-то ошибок не нашел.
Спасибо вам большое - экономит кучу времени!