Move data in columns to align them at the bottom

Hello everyone

I have a set of data that I would like to be aligned as per attached example.

I tried to record a macro 'move2btm' but when the data layout changes obviously it does not work.

Is there a way to achieve this result via macro or function?

thanks for any ideas

Excel 2021 ÷ 2024

Try this

Code:

---

Option Explicit


Sub move2btm()
    Dim r As Range
    Dim nBlanks As Long, c As Long   
    Set r = Range("A1").CurrentRegion   
    For c = 1 To r.Columns.Count
        nBlanks = 0
        On Error Resume Next
        nBlanks = r.Columns(c).SpecialCells(xlCellTypeBlanks).Count
        On Error GoTo 0       
        If nBlanks = 0 Then GoTo NextCol       
        Range(r.Cells(1, c), r.Cells(1, c).End(xlDown)).Cut
        r.Cells(nBlanks + 1, c).Select
        r.Parent.Paste
    NextCol:
    Next c
End Sub

---

only, don't run it a second time.

Bing Copilot helped me build this:

Code:

---

Dim ws As Worksheet, lastRow As Integer, lastCol As Integer, c As Integer, r As Integer
Set ws = ThisWorkbook.Sheets("ToBtm")
With ws
    lastRow = .Range("A1").CurrentRegion.Rows.Count
    lastCol = .Range("A1").CurrentRegion.Columns.Count
    For c = 1 To lastCol
        r = .Cells(ws.Rows.Count, c).End(xlUp).Row
        .Range(.Cells(1, c), .Cells(r, c)).Copy
        .Cells(lastRow + (lastRow - r) + 5, c).PasteSpecial Paste:=xlPasteValues
    Next
    Application.CutCopyMode = False
    .Range("A1").Select
End With

---

Now, do you really want to paste into same sheet? Do you want to delete original rows?

Hi Paul

I tried your code and it does what I wanted.
Thanks for your help

Riccardo

If you think you might run it twice, I can add a check. Otherwise it kind of goes South

however you run the macro, it does not destroy the order.

Code:

---

    Dim rngRegion As Range
    Dim col As Range
    Dim totalRows As Long, n As Long
    Dim output As String
    Dim arr() As Variant
    Dim itm() As Variant
    Dim var As String
    Dim i As Long, j As Long, lastColumn
   
    lastColumn = GetLastUsedColumn()
    ' Define the CurrentRegion based on the active cell
    Set rngRegion = Range(Cells(1, 1), Cells(1, lastColumn))
    'find the last row
    For Each col In rngRegion.Columns
        n = ActiveSheet.Cells(ActiveSheet.Rows.Count, col.Column).End(xlUp).Row
        If n > totalRows Then
            totalRows = n
        End If
    Next
    Set rngRegion = Range(Cells(1, 1), Cells(totalRows, lastColumn))
    ReDim itm(totalRows - 1)
    ' Loop through each column in the CurrentRegion
    For Each col In rngRegion.Columns
        'initial all elements in itm array
        For i = LBound(itm) To UBound(itm)
            itm(i) = ""
        Next
        arr = Range(Cells(1, col.Column), Cells(totalRows, col.Column))
        j = UBound(itm)
        For i = UBound(arr) To LBound(arr) Step -1
            If Len(arr(i, 1) & "") <> 0 Then
                itm(j) = arr(i, 1)
                j = j - 1
            End If
        Next
        For i = 0 To UBound(itm)
            Cells(i + 1, col.Column) = itm(i)
        Next
    Next col
End Sub


Function GetLastUsedColumn(Optional ws As Worksheet) As Long
    If ws Is Nothing Then Set ws = ActiveSheet


    Dim lastCol As Range
    Set lastCol = ws.Cells.Find(What:="*", _
                                After:=ws.Cells(1, 1), _
                                LookIn:=xlFormulas, _
                                LookAt:=xlPart, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlPrevious)


    If Not lastCol Is Nothing Then
        GetLastUsedColumn = lastCol.Column
    Else
        GetLastUsedColumn = 0 ' No data found
    End If
End Function

---

Another one, should be very fast...

Code:

---

Sub test()
    Dim a, i&, ii&, iii As Long, n&
    With Columns(1).SpecialCells(2).Areas(1).CurrentRegion
        a = .Value2
        For ii = 1 To UBound(a, 2)
            n = 0: iii = 0
            For i = UBound(a, 1) To 1 Step -1
                If a(i, ii) = "" Then
                    n = n + 1
                Else
                    Exit For
                End If
            Next
            If n Then
                For i = UBound(a, 1) - n To 1 Step -1
                    a(UBound(a, 1) - iii, ii) = a(i, ii)
                    iii = iii + 1
                    If i <= n Then a(i, ii) = ""
                Next
            End If
        Next
        .Value2 = a
    End With
End Sub

---

Quote:

---

Originally Posted by jindon

Another one, should be very fast...

Code:

---

Sub test()
    Dim a, i&, ii&, iii As Long, n&
    With Columns(1).SpecialCells(2).Areas(1).CurrentRegion
        a = .Value2
        For ii = 1 To UBound(a, 2)
            n = 0: iii = 0
            For i = UBound(a, 1) To 1 Step -1
                If a(i, ii) = "" Then
                    n = n + 1
                Else
                    Exit For
                End If
            Next
            If n Then
                For i = UBound(a, 1) - n To 1 Step -1
                    a(UBound(a, 1) - iii, ii) = a(i, ii)
                    iii = iii + 1
                    If i <= n Then a(i, ii) = ""
                Next
            End If
        Next
        .Value2 = a
    End With
End Sub

---

---

that is so much better, however you run the sub, same result output.

Hi Paul

no thanks, that's fine, I just need to 'launch' once for each dataset

thanks again everyone

and another:

Code:

---

Sub blah()
With Range("A1").CurrentRegion
  For Each colm In .SpecialCells(xlCellTypeConstants, 23).Columns
    colm.Cut colm.Offset(.Rows.Count - colm.Rows.Count)
  Next colm
End With
End Sub

---

very short, but needs error handling, in case, by accident run the code again.