Search Contextures Sites
Thanks to Dave Peterson, who wrote this technique.
To make it easier for users to sort data, and to help prevent scrambled data, you can add invisible rectangles at the top of your columns. When a rectangle is clicked, a macro runs.
In the macro, 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
Watch the steps in this Sort with Shapes video, and read the detailed instructions below.
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, and edit the code, if necessary, by changing the iCol variable, and starting cell, to match your worksheet.
Then on the Excel Ribbon, click the View tab, and click 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 Dim iFilter As Integer iCol = 7 'number of columns ' 2010-Oct-31 added space for autofilter dropdowns ' set iFilter to 0 if not using autofilter iFilter = 12 'width of drop down arrow 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 - iFilter, Left:=.Left) End With With myRect .OnAction = ThisWorkbook.Name & "!SortTable" '' 2010-Oct-31 revised to fill shapes in Excel 2007 '' .Fill.Visible = False .Fill.Solid .Fill.Transparency = 1# .Line.Visible = False End With Next myCell End With End Sub
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 = 7 '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(strCol & TopRow & ":" _ & strCol & 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
Last updated: September 16, 2013 7:56 PM
Contextures Inc., Copyright ©2015
All rights reserved.