Enterprise Software Solutions 

  Jump to: DW University, Employment

Excel VBA

'***********************************************************************
' Comments : When user double clicks on a column header, sort
' If the 1st cell in the column < last cell,
' then sort descending (assume already sorted ascending)
' ELSE, sort ascending
' Parameters : the cell range, calcel flag (both are normal event parms)
' Returns : nothing
' Created : Enterprise Software Solutions [09/15/1999]
' Modified :
'***********************************************************************
Public Sub Sort_Columns( _
ByVal Target As Excel.Range, Cancel As Boolean)
'this is the number of row between the title row and the firt data row
Dim iTitleToFirstRow As Integer
'Font to set the column header cell if it has just been sorted ascending
Dim bHeaderTemplateIsShadow As Boolean
'indicates the sort order as xlSortOrder that we'll use
Dim MySortOrder As Integer
Dim rMiscRange As Range
Dim rTotalsRange As Range
Dim rHeaderCell As Range
Dim bReportHasTotals As Boolean
Dim iDropDownCount As Integer
On Error GoTo ErrorHandler

'sort only if the cell is not empty and is a column header
If Target.Row <> Target.Worksheet.UsedRange.Row + 1 _
Or Len(Target.Value) <= 0 Then
GoTo ExitCleanup
End If

'***** determine some general settings about the template sheet
With Worksheets(gblconstTemplate)
'get the number of rows from the title row to the first detailrow
iTitleToFirstRow = .UsedRange.Rows.Count - 1
'get the normal Font of header cells
bHeaderTemplateIsShadow = _
.Cells(.UsedRange.Row + iTitleToFirstRow - 1, _
.UsedRange.Column) _
.Font.Shadow
End With

'***** don't allow total line to be a part of sort operation
'turn autofilter off
If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.ShowAllData
End If
'find total row
With ActiveSheet
Set rTotalsRange = .Range( _
.Cells(.UsedRange.Row + gbl_TITLE_ROWS, 1), _
.Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, .UsedRange.Columns.Count))
End With
Set rTotalsRange = rTotalsRange.Find(What:=TEXT_FOR_TOTAL_LINE, _
LookIn:=XlFindLookIn.xlValues, LookAt:=XlLookAt.xlPart, MatchCase:=False)
'Total row found!
'see if we have a total line in this report
If Not IsNothing(rTotalsRange) Then
'indicate that we have a total row
bReportHasTotals = True
'these IS a total row, so make sort range be up to total row
Set rMiscRange = Range( _
Cells(ActiveSheet.UsedRange.Row + gbl_TITLE_ROWS, Target.Column), _
Cells(rTotalsRange.Row - 1, Target.Column))
Else
'capture entire totals range
'there is NO total row, so set range to full data set
Set rMiscRange = ActiveSheet.UsedRange
Set rMiscRange = Range( _
Cells(Target.Row + 1, Target.Column), _
Cells(Target.Row + rMiscRange.Rows.Count - gbl_TITLE_ROWS, Target.Column))
End If

'find header cell
Set rHeaderCell = Target

'if the data is a number, then make the shadow status be the opposite
If IsNumeric(Cells(rMiscRange.Row, rMiscRange.Column)) Then
rHeaderCell.Font.Shadow = Not rHeaderCell.Font.Shadow
End If

'if col is already sorted ascending, sort it descending
If rHeaderCell.Font.Shadow = Not bHeaderTemplateIsShadow Then
MySortOrder = xlDescending
Else
MySortOrder = xlAscending
End If

'make all cells in header row be of Normal Font
With rMiscRange.Worksheet
.Range(.Cells(.UsedRange.Row + iTitleToFirstRow - 1, _
.UsedRange.Column), _
.Cells(.UsedRange.Row + iTitleToFirstRow - 1, _
.UsedRange.Columns.Count)) _
.Font.Shadow = bHeaderTemplateIsShadow
End With

'if the col is to be sorted ascending, then make it of Special Font
' (as long as it is not a numberic column)
If MySortOrder = xlAscending Then
rHeaderCell.Font.Shadow = Not bHeaderTemplateIsShadow
End If

'if the data is a number, then make the shadow status be the opposite
If IsNumeric(Cells(rMiscRange.Row, rMiscRange.Column)) Then
rHeaderCell.Font.Shadow = Not rHeaderCell.Font.Shadow
End If

'sort the colmn using the sort method of range object
rMiscRange.EntireRow.Sort Key1:=rMiscRange, _
Order1:=MySortOrder, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

'now refresh the hidden cells order (for hide repetative cells)
Hide_Repetitive_Cells Target.Worksheet.Name

ExitCleanup:
On Error Resume Next
'make the sheet be auto filtered again
ApplyAutoFilter
'cleanup objects
Set rMiscRange = Nothing
Set rHeaderCell = Nothing
Set rTotalsRange = Nothing
Set Target = Nothing
'do not do the normal excel thing for a double click
Cancel = True
Exit Sub
ErrorHandler:
Resume ExitCleanup
End Sub

[ Home ] [ Up ]

Send mail to Webmaster@ESScorporation.com with questions or comments about this web site.
Copyright © 2004 Enterprise Software Solutions, Inc.
Last modified: July 29, 2004