This macro will reverse the order of a range of data. You may flip data in a single row or in a single column of data (i.e., an N by 1 array or an 1 by N array). You may not select and entire row or an entire column.
Public Sub FlipSelection()
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 "Selection May Include Only 1 Row or 1 Column", _
vbExclamation, "Flip Selection"
Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then
MsgBox "You May Not Select An Entire Row", vbExclamation, _
"Flip Selection"
Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then
MsgBox "You May Not Select An Entire Column", vbExclamation, _
"Flip Selection"
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
Public Sub FlipSelection()
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 "Selection May Include Only 1 Row or 1 Column", _
vbExclamation, "Flip Selection"
Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then
MsgBox "You May Not Select An Entire Row", vbExclamation, _
"Flip Selection"
Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then
MsgBox "You May Not Select An Entire Column", vbExclamation, _
"Flip Selection"
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
No comments:
Post a Comment