Quickly sort data with this macro that runs when you click a hidden shape at the top of a column. The macro selects the whole data range, to help prevent scrambled data.
Thanks to Dave Peterson, who wrote this technique.
To see how the macro sorts the data, watch this short video. The written instructions are below the video.
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 hidden 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
To see the macro code, download the sample workbook. The zipped file contains macros, so enable macros when you open the file, if you want to test the macros.
Last updated: February 11, 2017 1:38 PM
Contextures RSS Feed