Sub PackByRows() ' реализация вашего "Нужно1"
     Dim r&, c&, i&, n&, v()
     v = Selection.Value
     n = UBound(v) ' кол-во строк в выделенном диапазоне
     For c = 1 To UBound(v, 2)
         ' находим первую пустую ячейку в столбце
         For i = 1 To n
             If Len(v(i, c)) = 0 Then Exit For
         Next
         ' проверяем остальные ячейки в столбце
         For r = i + 1 To n
             If Len(v(r, c)) Then
                 v(i, c) = v(r, c)
                 v(r, c) = Empty
                 i = i + 1
             End If
     Next r, c
     Selection = v
End Sub

Sub testColumns00()
      Dim c As Range
        
      ' работаем с выделенной областью
      ' сначала выполняем "сжатие" по строкам
      If Selection.Count = 1 Then Exit Sub
      PackByRows
        
      With Selection
          .Rows(1).Insert
          For Each c In .Columns
              c.Cells(0) = WorksheetFunction.CountA(c)
          Next
          Set c = .Offset(-1).Resize(.Rows.Count + 1)
          With .Parent.Sort
              With .SortFields
                  .Clear
                  .Add c.Rows(1), xlSortOnValues, xlDescending
              End With
              .SetRange c
              .Header = xlNo
              .Orientation = xlLeftToRight
              .Apply
          End With
          .Rows(0).Delete
      End With
End Sub

Public Sub test()
Dim i As Integer, j As Integer, k As Integer
Dim dC As Integer, dR As Integer
Const maxRow As Integer = 25, maxCln As Integer = 25 'задаем размеры для считывания
Const lName As String = "buff", lNmBasa As String = "test" 'имена целевого и базового листа
Dim arrK(1 To maxCln, 1 To 2) As Integer
Dim arr2(1 To maxRow, 1 To maxCln)
Dim arrOut(1 To maxRow, 1 To maxCln)

dC = 0 ' delta Colunm если выводить не в А1
dR = 0 ' delta Row
If SheetCheck(lName) = 0 Then Sheets.Add.Name = lName
Application.StatusBar = "Идёт считывание и сортировка данных..."

Application.ScreenUpdating = False
With Sheets(lNmBasa)
For j = 1 To maxCln
k = 0
For i = 1 To maxRow
     If .Cells(i, j) <> "" Then
     k = k + 1
     arr2(k, j) = .Cells(i, j)
     End If
Next i
DoEvents
arrK(j, 1) = j
arrK(j, 2) = k
Next j
Call sortArr(arrK)
For i = 1 To maxCln
     For j = 1 To maxRow
             arrOut(j, maxCln + 1 - i) = arr2(j, arrK(i, 1))
     Next j
Next i
End With
Sheets(lName).Cells(1 + dR, 1 + dC).Resize(maxRow, maxCln).ClearContents
Sheets(lName).Cells(1 + dR, 1 + dC).Resize(maxRow, maxCln) = arrOut

Application.ScreenUpdating = True
Application.StatusBar = "Вывод данных закончен"
End Sub

Function SheetCheck(ByVal ShName As String) As Byte
     Dim x As Byte
      
     x = 0
     For Each ws In ActiveWorkbook.Sheets
         If ws.Name = ShName Then
             x = 1
             Exit For
         End If
     Next ws
     SheetCheck = x
End Function

Private Sub sortArr(arr1() As Integer)
Dim fOut As Byte
Dim LBdr As Integer, RBdr As Integer
Dim buff1 As Integer
Dim str1 As String

LBdr = 1
RBdr = UBound(arr1, 1)
Do While 1
fOut = 1
For i = 1 To RBdr - 1
     If arr1(i, 2) > arr1(i + 1, 2) Then
     k = i
     fOut = 0
     buff1 = arr1(i, 1)
     arr1(i, 1) = arr1(i + 1, 1)
     arr1(i + 1, 1) = buff1
     buff1 = arr1(i, 2)
     arr1(i, 2) = arr1(i + 1, 2)
     arr1(i + 1, 2) = buff1
     End If
Next i
If fOut Then Exit Do
RBdr = k
fOut = 1

For i = RBdr To LBdr + 1 Step -1
     If arr1(i, 2) < arr1(i - 1, 2) Then
     k = i
     fOut = 0
     buff1 = arr1(i, 1)
     arr1(i, 1) = arr1(i - 1, 1)
     arr1(i - 1, 1) = buff1
     buff1 = arr1(i, 2)
     arr1(i, 2) = arr1(i - 1, 2)
     arr1(i - 1, 2) = buff1
     End If
Next i
If fOut Then Exit Do
LBdr = k
Loop

End Sub

Sub testColumns00()
     Dim c As Range
      
     Application.ScreenUpdating = False                      ' откл. обновление экрана
     ActiveSheet.EnableCalculation = False                   ' откл. авторасчет формул
      
     ' работаем с выделенной областью
     ' сначала выполняем "сжатие" по строкам
     If Selection.Count = 1 Then Exit Sub
     PackByRows
          
     With Selection
         .Rows(1).Insert
         For Each c In .Columns
             c.Cells(0) = WorksheetFunction.CountA(c)
         Next
         Set c = .Offset(-1).Resize(.Rows.Count + 1)
         With .Parent.Sort
             With .SortFields
                 .Clear
                 .Add c.Rows(1), xlSortOnValues, xlDescending
             End With
             .SetRange c
             .Header = xlNo
             .Orientation = xlLeftToRight
             .Apply
         End With
         .Rows(0).Delete
     End With
      
     ' вкл. все, что отключали
     ActiveSheet.EnableCalculation = True
     Application.ScreenUpdating = True
End Sub