Keith,
After testing your code: congratulations: good start, since it works!
As an exercise: how can we reduce runtime?
I was thinking of a solution, which would first calculate all movements and then execute them, but this post isn't going so far... To give you some ideas: here are some enhancements. I think it's working OK.
The main purpose is to avoid loops.
At the end you add names and then you delete them: this is timeconsuming as is the one-by-one cut-and-insert, the major runtoime problem. I feel at least all those names can be avoided. I feel with the method like you'll find in the code
"OriginalRows = rng", storing values in a "computed array" without using Excel itself, we can get rid of the names and paste "something" in an extra column at once...
As you said, we are no "profs", but if you like this, we could continue this way ...
kind regards,
Erik
this was deleted
For r = 2 To rCount
Cells(r, cCount + 1).Value = r
Next r
the same result without loop
Dim rng As Range
Set rng = Range(Cells(2, cCount + 1), Cells(rCount, cCount + 1))
With rng
.Formula = "=Row()"
.Value = .Value
End With
another deleted loop
For r = 2 To rCount
OriginalRows(r) = Cells(r, cCount + 1).Value
Next r
replaced by a oneliner
OriginalRows = rng 'using "computed array"
therefore = Dim OriginalRows As
Variant
and : wbSort.Names.Add Name:="temprow" & r, _
RefersTo:=Range(Cells(rngSort.Row +
OriginalRows(r - 1, 1) - 1, rngSort.Column), _
Cells(rngSort.Row +
OriginalRows(r - 1, 1) - 1, rngSort.Column + cCount - 1))
don't ask me exactly why but it works
Code:
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 Variant
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 Variant
'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
Dim rng As Range
Set rng = Range(Cells(2, cCount + 1), Cells(rCount, cCount + 1))
With rng
.Formula = "=Row()"
.Value = .Value
End With
'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
OriginalRows = rng 'using "computed array"
'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
'see the little changes OriginalRows(r - 1, 1)
wbSort.Names.Add Name:="temprow" & r, _
RefersTo:=Range(Cells(rngSort.Row + OriginalRows(r - 1, 1) - 1, rngSort.Column), _
Cells(rngSort.Row + OriginalRows(r - 1, 1) - 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
