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.