Button-Instigated Sort: One More Thing...

[(PeteCresswell)]

Thanks to Chip Pearson's guide (http://cpearson.com/excel/vbe.htm),
I've got some code working where I can create buttons at the top of a
worksheet's columns that allow the user to toggle the sort sequence of the
entire sheet based on that column.

Maybe I've been drinking too much coffee again... or maybe I just don't have
enough to do... but it's occurred to me that it would be nice to have some
visual indication of the sort status/functionality.

Right now I'm just putting an invisible rectangle over the column header cell as
in:
--------------------------------------------------------------------
With myCell
Set myRect = .Parent.Shapes.AddShape(Type:=gExcelShape_Rectangle,
Top:=.Top, Height:=.Height, Width:=.Width, Left:=.Left)
End With

With myRect
.OnAction = theMacroName
.Fill.Visible = False
.Line.Visible = False
End With
--------------------------------------------------------------------

What I'd really like to have up there is one or more objects that tell
the user that
----------------------------------------------
a) They have sorted on that particular column
b) What sequence the sort is in
----------------------------------------------

From the user's perspective, I picture a little triangle in the lower right of
the column header that becomes visible when the sheet is sorted on that column
and invisible when the sheet is sorted on another column (whose header then
shows *it's* triangle).

Then, to add a little more, I see the triangle pointing down if the column
is sorted ASC and pointing up if the column is sorted DESC.


All I can think of is three objects instead of one on each column:
----------------------------------------
- The existing transparent rectangle that
still fires the click events to invoke the
sort routine
- A triangle (bitmap?) pointing upwards
- A triangle pointing downwards
----------------------------------------

Then the sort routine would somehow make the rectangles visible/invisible
or move them Front/Back as needed to represent the .Sorted state.


I'm wondering if greater minds than mine have been here.

Anybody heard of doing something like this?

 

[(PeteCresswell)]

Per (PeteCresswell):

I'm wondering if greater minds than mine have been here.

Anybody heard of doing something like this?

Maybe I should add that the tricky part would seem to be in doing it all from
another application's VBA in a virgin spreadsheet that the application has just
created - i.e. if bitmaps were used for the triangles, they'd have to come from
somewhere....

 

[Dave Peterson]

How about just adding an up arrow or a down arrow depending on how the data was
sorted?

This deletes an arrow (with a specific name), then adds an arrow back to the
cell that contained the rectangle that was clicked.

I know that you've changed a few things, but maybe you could modify it in your
version of the code:

Sub SortTable()

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
Dim myArrow As Shape
Dim myShapeType As Long

TopRow = 2
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:=xlNo

On Error Resume Next
.Shapes("ArrowIndicator").Delete
On Error GoTo 0

If mySortOrder = xlAscending Then
myShapeType = msoShapeDownArrow
Else
myShapeType = msoShapeUpArrow
End If

With .Shapes(Application.Caller).TopLeftCell
Set myArrow = .Parent.Shapes.AddShape(Type:=myShapeType, _
Top:=.Top, Left:=.Left, Width:=.Width / 3, Height:=.Height)
End With

With myArrow
.Name = "ArrowIndicator"
'any other formatting choices???
End With

End With

End Sub

ps. I changed the sort to use headers:=xlno since the headers were in row 1 and
the data started in row 2--but the table being sorted started in row 2.

 

[(PeteCresswell)]

Per Dave Peterson:

How about just adding an up arrow or a down arrow depending on how the data was
sorted?

This deletes an arrow (with a specific name), then adds an arrow back to the
cell that contained the rectangle that was clicked.

I know that you've changed a few things, but maybe you could modify it in your
version of the code:

Sub SortTable()

Dim myTable As Range
Dim myColToSort As Long
Dim curWks As Worksheet

I guess great minds reach similar conclusions... -)

That's what I was just fooling around with when I decided to refresh the NG's
messages and saw yours: msoUpArrow and msoDownArrow.

And the positioning/sizing was what I was starting to scratch my head about -
solved conveniently by your code sample:
' ----------------------------------------------------------------------
With .Shapes(Application.Caller).TopLeftCell
Set myArrow = .Parent.Shapes.AddShape(Type:=myShapeType, _
Top:=.Top, Left:=.Left, Width:=.Width / 3, Height:=.Height)
End With
' -----------------------------------------------------------------------

Thanks for the help.... and the validation!!!!

 

[(PeteCresswell)]

Per (PeteCresswell):

I guess great minds reach similar conclusions... -)

I think I've got pretty much of a wrap on this thing.

Sample spreadsheet: http://tinyurl.com/2zhq9x


The Up/Down arrows were harder to work with and I finally stumbled on to the
graphics primitives - which included a triangle which fit the bill nicely.

Thanks for the help.

 

[(PeteCresswell)]

Per (PeteCresswell):

Sample spreadsheet: http://tinyurl.com/2zhq9x

Here's the VBA code I wound up with in the MS Access app that creates the
spreadsheets. If anybody wants to play with it, I can flip them
and eMail with a .txt file so the word wrapping will go away.
-----------------------------------------------------------------------
Public Sub SortButtons_Create(ByVal theRowNum_Buttons As Long, ByVal
theRowNum_DataFirst As Long, ByVal theRowNum_DataLast As Long, ByVal
theColNum_ButtonFirst As Long, ByVal theColNum_ButtonLast As Long, ByVal
theColNum_DataFirst As Long, ByVal theColNum_DataLast As Long, ByVal
theArrowColor As Long, ByRef theWS As Excel.Worksheet)
13000 debugStackPush mModuleName & ": SortButtons_Create"
13001 On Error GoTo SortButtons_Create_err

' PURPOSE: - To put a series of invisible rectangles on a worksheet which,
when clicked,
' call a routine that sorts the entire sheet's data on that
column's values.
' - To create up/down arrows to supplement the rectangles by
serving as visual indicator
' of what is sorted on and how
' - To create/install a macro named "SortSheet" that will serve as
the routine that sorts the sheet
' ACCEPTS: - Row number of the row to have the invisible rectangles
installed on it
' - Row number of the first row tb sorted
' - Row number of the last row tb sorted
' - Col number of first column that gets a button
' - Col number of last column that gets a button
' - Col number of first column tb sorted (generally same as first
col to get a button)
' - Col number of last column tb sorted (generally same as last
col to get a button)
' - Color tb used when drawing the Up/Down arrows. Must be valid in
Excel's scheme of things.
' e.g. 10 = Red
' - Pointer to the Excel.Worksheet where the buttons go

13002 Dim myWB As Excel.Workbook
Dim myRange As Excel.Range
Dim curCell As Excel.Range
Dim curButton As Shape
Dim curUpArrow As Shape
Dim curDownArrow As Shape
Dim myParentModule As VBComponent
Dim myCodeModule As CodeModule

Dim curRI As RangeInfo

Dim curCellAddress As String
Dim curColNumString As String
Dim myMacroCode As String

Const myArrowHeight As Long = 5
Const myArrowWidth As Long = 5

Const myMacroName As String = "SortSheet" 'This value is implicit
in myMacroCode1

' -----------------------------------------------------------
' We use these constants to assemble the macro tb added to the SS
' which does the actual sorting

Const myMacroCode1 As String = _
" Sub SortSheet() " & vbCrLf & vbCrLf & _
"'PURPOSE: - To allow user to sort the entire sheet by clicking on
a column header" & vbCrLf & _
"' - To maintain visibility of up/down arrows which
indicate which cols are sorted and" & vbCrLf & _
"' the direction of the sort" & vbCrLf & _
"'" & vbCrLf & _
"' NOTES: 1) This routine's code was generated by the same
application (""CDO"")" & vbCrLf & _
"' that created this spreadsheet. That is why the data
area's dimensions" & vbCrLf & _
"' are supplied via constants: the creating app
concatonated them into this code" & vbCrLf & _
"' Pete
Cresswell" & vbCrLf & _
"' 610-513-0066" & vbCrLf & _
" Dim myWS As Worksheet " & vbCrLf & _
" Dim myRange As Range " & vbCrLf & vbCrLf & _
" Dim i As Long " & vbCrLf & _
" Dim mySortCol As Long " & vbCrLf & _
" Dim mySortOrder As Long " & vbCrLf & vbCrLf & _
" Const rowNum_FirstData As Long = "

Const myMacroCode2 As String = " Const rowNum_LastData As Long =
"
Const myMacroCode3 As String = " Const colNum_FirstData As Long =
"
Const myMacroCode4 As String = " Const colNum_LastData As Long =
"

Const myMacroCode5 As String = _
" Set myWS = ActiveSheet " & vbCrLf & vbCrLf & _
" With myWS " & vbCrLf & _
" For i = colNum_FirstData To colNum_LastData" & vbCrLf & _
" .Shapes(""UpArrow"" & Format$(i, ""000"")).Visible =
False" & vbCrLf & _
" .Shapes(""DownArrow"" & Format$(i, ""000"")).Visible =
False" & vbCrLf & _
" Next i" & vbCrLf & vbCrLf & _
" mySortCol = .Shapes(Application.Caller).TopLeftCell.Column "
& vbCrLf & _
" Set myRange = .Range(.Cells(rowNum_FirstData,
colNum_FirstData), .Cells(rowNum_LastData, colNum_LastData)) " & vbCrLf & vbCrLf
& _
" If .Cells(rowNum_FirstData, mySortCol).Value <
..Cells(rowNum_LastData, mySortCol).Value Then " & vbCrLf & _
" mySortOrder = xlDescending " & vbCrLf & _
" .Shapes(""DownArrow"" & Format$(mySortCol,
""000"")).Visible = True" & vbCrLf & _
" Else " & vbCrLf & _
" .Shapes(""UpArrow"" & Format$(mySortCol,
""000"")).Visible = True" & vbCrLf & _
" mySortOrder = xlAscending " & vbCrLf & _
" End If " & vbCrLf & vbCrLf & _
" myRange.Sort key1:=.Cells(rowNum_FirstData, mySortCol),
order1:=mySortOrder " & vbCrLf & _
" End With " & vbCrLf & _
" End Sub "

' ------------------------------------------------------------------------
' First thing, we need to create a code module in the target spreadsheet
' that will hold the code to handle our button click events

13010 Set myWB = theWS.Parent
13011 Set myParentModule = myWB.VBProject.VBComponents.Add(vbext_ct_StdModule)
13012 Set myCodeModule = myParentModule.CodeModule

13019 myMacroCode = myMacroCode1 & theRowNum_DataFirst & vbCrLf & myMacroCode2
& theRowNum_DataLast & vbCrLf & myMacroCode3 & theColNum_ButtonFirst & vbCrLf &
myMacroCode4 & theColNum_DataLast & vbCrLf & vbCrLf & myMacroCode5

13020 With myCodeModule
13021 .InsertLines .CountOfLines + 1, myMacroCode
13029 End With

' ------------------------------------------------------------------------
' Now that we've got our macro code installed in the target Excel workbook,
' we loop through the worksheet's columns, creating a rectangle/button
' and a couple of directional indicator arrows in each column header cell
' NB: If the text in a column header is right-justified, you'll need to
' have done a .IndentLevel=1 to slide it over far enough so the Up/Down
' arrows do not conflict with it

13030 With theWS
13031 Set myRange = .Range(.Cells(theRowNum_Buttons, theColNum_ButtonFirst),
..Cells(theRowNum_Buttons, theColNum_ButtonLast))
13039 For Each curCell In myRange.Cells

13040 With curCell
13041 curCellAddress = .Address(ReferenceStyle:=xlR1C1)
13044 Set curButton = .Parent.Shapes.AddShape(Type:=msoShapeRectangle,
Top:=.Top, Height:=.Height, Width:=.Width, Left:=.Left)
13045 Set curUpArrow =
..Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Top:=(.Top + .Height -
myArrowHeight - 4), Height:=myArrowHeight, Width:=myArrowWidth, Left:=(.Left +
..Width - myArrowWidth - 2))
13046 Set curDownArrow =
..Parent.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, Top:=(.Top + .Height -
myArrowHeight - 4), Height:=myArrowHeight, Width:=myArrowWidth, Left:=(.Left +
..Width - myArrowWidth - 2))
13049 End With

13050 curRI = RangeAddress_Parse(curCellAddress)
13059 curColNumString = Format$(curRI.ColLeft, "000")
13060 With curButton
13061 .OnAction = myMacroName
13062 .Fill.Visible = msoFalse
13063 .Line.Visible = msoFalse
13069 End With

13100 With curUpArrow
13101 .Name = "UpArrow" & curColNumString
12109 .Visible = msoFalse

13110 With .Fill
13111 .Solid
13112 .ForeColor.SchemeColor = theArrowColor
13119 End With
13199 End With

13200 With curDownArrow
13201 .Name = "DownArrow" & curColNumString
13202 .Visible = msoFalse
13209 .IncrementRotation 180

13211 With .Fill
13212 .Solid
13213 .ForeColor.SchemeColor = theArrowColor
13219 End With
13299 End With

13990 Next curCell
13999 End With

SortButtons_Create_xit:
DebugStackPop
On Error Resume Next
Set myRange = Nothing
Set curCell = Nothing
Set curButton = Nothing
Set curDownArrow = Nothing
Set curUpArrow = Nothing
Set myParentModule = Nothing
Set myCodeModule = Nothing
Set myWB = Nothing
Exit Sub

SortButtons_Create_err:
BugAlert True, ""
Resume SortButtons_Create_xit
End Sub