Move data in columns to align them at the bottom

[RIC63]

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

[Paul_Hossler]

Try this

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

[arnelgp]

only, don't run it a second time.

[June7]

Bing Copilot helped me build this:

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?

[RIC63]

Hi Paul

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

Riccardo

[Paul_Hossler]

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

[arnelgp]

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

    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

[jindon]

Another one, should be very fast...

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

[arnelgp]

Another one, should be very fast...

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.

[RIC63]

Hi Paul

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

thanks again everyone

[p45cal]

and another:

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

[arnelgp]

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