Option Base 1
Sub SortEntireCells()
'This macro takes a selected range and "sorts" it by
'cutting and inserting rows, so that links to the actual
'cells will "follow" the cells after they are sorted.
'
'In order to use this macro, select a data range and run this.
'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.
Application.ScreenUpdating = False
Dim rngSort As Range
Dim r As Integer
Dim rCount As Integer, cCount As Integer
Dim keyOffset As Integer
Dim OriginalRows() As Integer
Dim wbSort As Workbook
Set wbSort = ActiveWorkbook
Set rngSort = Selection
keyOffset = ActiveCell.Column - Selection.Column
rCount = rngSort.Rows.Count
cCount = rngSort.Columns.Count
'We this array to store row numbers
ReDim OriginalRows(rCount) As Integer
'Copy the range to be sorted into another workbook
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
'Storing the original position of each row in the range
With Cells(1, cCount + 1)
.Value = "Original Row"
.Font.Bold = True
.Font.Italic = True
End With
For r = 2 To rCount
Cells(r, cCount + 1).Value = r
Next r
'Select entire copied range and the added row numbers, then sort
ActiveSheet.UsedRange.Select
Selection.Sort Key1:=Cells(1, 1).Offset(0, keyOffset), Header:=xlYes
'Store the original row numbers in an array in the new sorted order
For r = 2 To rCount
OriginalRows(r) = Cells(r, cCount + 1).Value
Next r
'Close the temporary workbook
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
'Back to the original workbook
wbSort.Activate
'Creating a temporary name for each row in original range,
'the "number" of each name corresponds to the position in the
'sorted range
For r = 2 To rCount
wbSort.Names.Add Name:="temprow" & r, _
RefersTo:=Range(Cells(rngSort.Row + OriginalRows(r) - 1, rngSort.Column), _
Cells(rngSort.Row + OriginalRows(r) - 1, rngSort.Column + cCount - 1))
Next r
'Cut and insert rows to their new order.
For r = 2 To rCount
If Range("temprow" & r).Row <> rngSort.Cells(r, 1).Row Then 'Skip row if it's already in the right place
Range("temprow" & r).Cut
rngSort.Cells(r, 1).Insert Shift:=xlDown
End If
Next r
'Delete the temporary row names
For Each nm In wbSort.Names
If Left(nm.Name, 7) = "temprow" Then nm.Delete
Next nm
Application.ScreenUpdating = True
End Sub
