Option Explicit
Option Base 1
Sub SortEntireCells()
'Erik Van Geit
'051211 2206
'"SORT" selected range
'cutting and inserting rows, so that links to the actual
'cells will "follow" the cells after they are sorted.
'
'The selected data range should contain headers/field names.
'The sort "key" will be the header in the column of the active cell.
'The range to be sorted can be one or several columns.
'
'EXAMPLE
'BEFORE
'sheet1 sheet2 display
'H1 =sheet1!A1 H1
'a3 =sheet1!A2 a3
'a1 =sheet1!A3 a1
'a2 =sheet1!A4 a2
'AFTER
'sheet1 sheet2 display (not changed)
'H1 =sheet1!A1 H1
'a1 =sheet1!A4 a3
'a2 =sheet1!A2 a1
'a3 =sheet1!A3 a2
Dim rngSort As Range
Dim i As Long
Dim rr As Long
Dim ori As Long
Dim rCount As Long
Dim cCount As Integer
Dim keyOffset As Integer
Dim rc As Integer
Dim rcc As Integer
Dim OriginalRows As Variant
Dim wbSort As Workbook
Set wbSort = ActiveWorkbook
Set rngSort = Selection
keyOffset = ActiveCell.Column - Selection.Column
rCount = rngSort.Rows.Count
cCount = rngSort.Columns.Count
ReDim OriginalRows(rCount) As Variant
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells(1, cCount + 1).Value = "Original Row"
Dim rng As Range
Set rng = Range(Cells(2, cCount + 1), Cells(rCount, cCount + 1))
With rng
.Formula = "=Row()"
.Value = .Value
End With
ActiveSheet.UsedRange.Sort Key1:=Cells(1, 1).Offset(0, keyOffset), order1:=xlAscending, Header:=xlYes
OriginalRows = rng 'using "computed array"
.DisplayAlerts = False
ActiveWorkbook.Close
.DisplayAlerts = True
wbSort.Activate
rr = rngSort.Row
rc = rngSort.Column + cCount
rcc = rngSort.Column + cCount * 2 - 1
.DisplayStatusBar = True
Cells(1, rngSort(1).Column).Resize(Rows.Count, cCount).Insert
For i = LBound(OriginalRows, 1) To UBound(OriginalRows, 1)
ori = OriginalRows(i, 1)
Range(Cells(ori, rc), Cells(ori, rcc)).Cut Range(Cells(i + rr, 1), Cells(i + rr, cCount))
.StatusBar = "sorting: " & Round(i / rCount * 100, 0) & "%"
Next
Range(Cells(rr + 1, 1), Cells(rr + rCount - 1, cCount)).Cut Range(Cells(rr + 1, rc), Cells(rr + rCount - 1, rc + cCount - 1))
Cells(1, 1).Resize(Rows.Count, cCount).Delete
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
