Public Sub Reverse_Rows_or_Columns()
'This Macro will reverse a selection of rows or columns.
'Note: you cannot select an etire row or column, but one
'cell less than that will work fine.
'Don't forget to assign this macro a keyboard shortcut or
'a toolbar button.
Dim Arr() As Variant
Dim rng As Range
Dim c As Range
Dim Rw As Long
Dim Cl As Long
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set rng = Selection
Rw = Selection.Rows.Count
Cl = Selection.Columns.Count
If Rw > 1 And Cl > 1 Then
MsgBox "Must select either a range of rows or columns, but not simultaneaously columns and rows.", _
vbExclamation, "Reverse Rows or Columns"
Exit Sub
End If
If rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then
MsgBox "Can't select an entire row, only up to one cell less than an entire row.", vbExclamation, _
"Reverse Rows or Columns"
Exit Sub
End If
If rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then
MsgBox "Can't select an entire column, only up to one cell less than an entire column.", vbExclamation, _
"Reverse Rows or Columns"
Exit Sub
End If
If Rw > 1 Then
ReDim Arr(Rw)
Else
ReDim Arr(Cl)
End If
Rw = 0
For Each c In rng
Arr(Rw) = c.Formula
Rw = Rw + 1
Next c
Rw = Rw - 1
For Each c In rng
c.Formula = Arr(Rw)
Rw = Rw - 1
Next c
EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Hi,Hi All,
Can guide how to copy data in reverse order ?
Thank you very much !
Hi,
The below code will do the work
Code:Public Sub Reverse_Rows_or_Columns() 'This Macro will reverse a selection of rows or columns. 'Note: you cannot select an etire row or column, but one 'cell less than that will work fine. 'Don't forget to assign this macro a keyboard shortcut or 'a toolbar button. Dim Arr() As Variant Dim rng As Range Dim c As Range Dim Rw As Long Dim Cl As Long On Error GoTo EndMacro Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set rng = Selection Rw = Selection.Rows.Count Cl = Selection.Columns.Count If Rw > 1 And Cl > 1 Then MsgBox "Must select either a range of rows or columns, but not simultaneaously columns and rows.", _ vbExclamation, "Reverse Rows or Columns" Exit Sub End If If rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then MsgBox "Can't select an entire row, only up to one cell less than an entire row.", vbExclamation, _ "Reverse Rows or Columns" Exit Sub End If If rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then MsgBox "Can't select an entire column, only up to one cell less than an entire column.", vbExclamation, _ "Reverse Rows or Columns" Exit Sub End If If Rw > 1 Then ReDim Arr(Rw) Else ReDim Arr(Cl) End If Rw = 0 For Each c In rng Arr(Rw) = c.Formula Rw = Rw + 1 Next c Rw = Rw - 1 For Each c In rng c.Formula = Arr(Rw) Rw = Rw - 1 Next c EndMacro: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub
Hi,
The below code will do the work
Code:Public Sub Reverse_Rows_or_Columns() 'This Macro will reverse a selection of rows or columns. 'Note: you cannot select an etire row or column, but one 'cell less than that will work fine. 'Don't forget to assign this macro a keyboard shortcut or 'a toolbar button. Dim Arr() As Variant Dim rng As Range Dim c As Range Dim Rw As Long Dim Cl As Long On Error GoTo EndMacro Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set rng = Selection Rw = Selection.Rows.Count Cl = Selection.Columns.Count If Rw > 1 And Cl > 1 Then MsgBox "Must select either a range of rows or columns, but not simultaneaously columns and rows.", _ vbExclamation, "Reverse Rows or Columns" Exit Sub End If If rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then MsgBox "Can't select an entire row, only up to one cell less than an entire row.", vbExclamation, _ "Reverse Rows or Columns" Exit Sub End If If rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then MsgBox "Can't select an entire column, only up to one cell less than an entire column.", vbExclamation, _ "Reverse Rows or Columns" Exit Sub End If If Rw > 1 Then ReDim Arr(Rw) Else ReDim Arr(Cl) End If Rw = 0 For Each c In rng Arr(Rw) = c.Formula Rw = Rw + 1 Next c Rw = Rw - 1 For Each c In rng c.Formula = Arr(Rw) Rw = Rw - 1 Next c EndMacro: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub