Sort
With Invisible Rectangles
Thanks to Dave Peterson, who wrote this technique.
To make sorting easier for users, and to help prevent scrambled data,
you can add invisible rectangles at the top of your columns. When a
rectangle is clicked, the whole data range is selected, and the data
is sorted by the column in which the rectangle was clicked. The zipped
sample workbook can be downloaded here: SortClick.zip
Create
the rectangles
Run the following code once, to create the rectangles at the top of
the table. You can change the iCol variable, to match the number
of columns in your table.
To run the code, copy
it to a regular code module, then in Excel, choose Tools | Macro
| Macros. Select the SetupOneTime macro, and click the Run button..
Sub SetupOneTime()
'adds rectangle at top of each column
'code written by Dave Peterson 2005-10-22
Dim myRng As Range
Dim myCell As Range
Dim curWks As Worksheet
Dim myRect As Shape
Dim iCol As Integer
iCol = 10 '10 columns -- change this to the number of
'columns in your table
Set curWks = ActiveSheet
With curWks
Set myRng = .Range("a1").Resize(1, iCol)
For Each myCell In myRng.Cells
With myCell
Set myRect = .Parent.Shapes.AddShape _
(Type:=msoShapeRectangle, _
Top:=.Top, Height:=.Height, _
Width:=.Width, Left:=.Left)
End With
With myRect
.OnAction = ThisWorkbook.Name & "!SortTable"
.Fill.Visible = False
.Line.Visible = False
End With
Next myCell
End With
End Sub
SortTable
Procedure
The following code runs when one of the rectangles
is clicked. You can change the TopRow, iCol and strCol
variables, to match the layout of your table.
Sub SortTable()
'code written by Dave Peterson 2005-10-22
'2006-08-06 updated to accommodate hidden rows
Dim myTable As Range
Dim myColToSort As Long
Dim curWks As Worksheet
Dim mySortOrder As Long
Dim FirstRow As Long
Dim TopRow As Long
Dim LastRow As Long
Dim iCol As Integer
Dim strCol As String
Dim rng As Range
Dim rngF As Range
TopRow = 1
iCol = 10 'number of columns in the table
strCol = "A" ' column to check for last row
Set curWks = ActiveSheet
With curWks
LastRow = .Cells(.Rows.Count, strCol).End(xlUp).Row
If Not .AutoFilterMode Then
Set rng = .Range(.Cells(TopRow, strCol), _
.Cells(LastRow, strCol))
Else
Set rng = .AutoFilter.Range
End If
Set rngF = Nothing
On Error Resume Next
With rng
'visible cells in first column of range
Set rngF = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
End With
On Error GoTo 0
If rngF Is Nothing Then
MsgBox "No visible rows. Please try again."
Exit Sub
Else
FirstRow = rngF(1).Row
End If
myColToSort = .Shapes(Application.Caller).TopLeftCell.Column
Set myTable = .Range("A" & TopRow & ":A" _
& LastRow).Resize(, iCol)
If .Cells(FirstRow, myColToSort).Value _
< .Cells(LastRow, myColToSort).Value Then
mySortOrder = xlDescending
Else
mySortOrder = xlAscending
End If
myTable.Sort key1:=.Cells(FirstRow, myColToSort), _
order1:=mySortOrder, _
header:=xlYes
End With
End Sub
|
|
