Уже нашел подходящий макрос:
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
Средний
