spirodem
asked on
sorting
in column a i have data that looks like this - 11k,11n,12p,55s,100,100a,1 01,102,105 ,110,110a, 124a,124@, 12e,
i need it to sort the following way - the sort must find the firts didget, then the second etc
in other words - 100, 100a, 101, 102, 110, 110a, 11k, 11n, etc
i need it to sort the following way - the sort must find the firts didget, then the second etc
in other words - 100, 100a, 101, 102, 110, 110a, 11k, 11n, etc
Use LEFT() and MID() to separate the elements into columns and then sort on those columns.
fp - That is surely 'one you prepared earlier' !! Patrick
spirodem,
Have a look at the following file for how to split up the data and then sort it:
http://www.asdy88.dsl.pipex.com/Experts%20Exchange/spirodem02.xls
Patrick
Have a look at the following file for how to split up the data and then sort it:
http://www.asdy88.dsl.pipex.com/Experts%20Exchange/spirodem02.xls
Patrick
Hi Patrick,
Well, yes, the Sort routine is something I wrote in 1994, but the "Sort_Column_A" routine is bespoke! :)
PS. In your example, if you change cell B1 to:
=MID($A1,COLUMN()-1,1)
You can then copy that to all the other cells (either across the columns of the same row, or to any cells [from column B onwards] on any of the other rows) without changing anything :)
BFN,
fp.
Well, yes, the Sort routine is something I wrote in 1994, but the "Sort_Column_A" routine is bespoke! :)
PS. In your example, if you change cell B1 to:
=MID($A1,COLUMN()-1,1)
You can then copy that to all the other cells (either across the columns of the same row, or to any cells [from column B onwards] on any of the other rows) without changing anything :)
BFN,
fp.
ASKER
fanpages
the code works however
A1:c1 are the headings so the code needs to start from a2:c2 and it needs to sort all if it based on column a
the code works however
A1:c1 are the headings so the code needs to start from a2:c2 and it needs to sort all if it based on column a
Hi,
Well, yes, the code works according to your original question :)
Do you mean that the data starts on row 2, and you need column A to be the sorted key (as per the rules above), but also that columns B & C must follow the re-ordered data?
If so, then try this...
Public Sub Sort_Column_A_to_C()
' -------------------------- ---------- ---------- ---------- ---------- ----------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' -------------------------- ---------- ---------- ---------- ---------- ----------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str Array, , True)) Then
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row ), vbTab)
objCell.Resize(1&, 3) = vntSplit
Next objCell
End If
End Sub
BFN,
fp.
Well, yes, the code works according to your original question :)
Do you mean that the data starts on row 2, and you need column A to be the sorted key (as per the rules above), but also that columns B & C must follow the re-ordered data?
If so, then try this...
Public Sub Sort_Column_A_to_C()
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row
objCell.Resize(1&, 3) = vntSplit
Next objCell
End If
End Sub
BFN,
fp.
Alternatively, if you do not wish the numeric data to be converted to text:
Public Sub Sort_Column_A_to_C_Retain_ Formatting ()
' -------------------------- ---------- ---------- ---------- ---------- ----------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' -------------------------- ---------- ---------- ---------- ---------- ----------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str Array, , True)) Then
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row ), vbTab)
objCell = vntSplit(0)
objCell.Offset(, 1) = vntSplit(1)
objCell.Offset(, 2) = vntSplit(2)
Next objCell
End If
End Sub
BFN,
fp.
Public Sub Sort_Column_A_to_C_Retain_
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row
objCell = vntSplit(0)
objCell.Offset(, 1) = vntSplit(1)
objCell.Offset(, 2) = vntSplit(2)
Next objCell
End If
End Sub
BFN,
fp.
ASKER
i get an error here blnQuick_Sort_Strings
The last code segment I posted was not to replace the existing listing, it was an additional
Just to be clear, please use this code (and remove all existing code):
Public Sub Sort_Column_A_to_C()
' -------------------------- ---------- ---------- ---------- ---------- ----------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' -------------------------- ---------- ---------- ---------- ---------- ----------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str Array, , True)) Then
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row ), vbTab)
objCell.Resize(1&, 3) = vntSplit
Next objCell
End If
End Sub
Public Sub Sort_Column_A_to_C_Retain_ Formatting ()
' -------------------------- ---------- ---------- ---------- ---------- ----------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' -------------------------- ---------- ---------- ---------- ---------- ----------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str Array, , True)) Then
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row ), vbTab)
objCell = vntSplit(0)
objCell.Offset(, 1) = vntSplit(1)
objCell.Offset(, 2) = vntSplit(2)
Next objCell
End If
End Sub
Private Function blnQuick_Sort_Strings(ByRe f strArray() As String, _
Optional ByRef lngLow_Value As Long = -1&, _
Optional ByRef lngHigh_Value As Long = -1&, _
Optional ByVal blnAlpha_Sort As Boolean = True) As Boolean
' -------------------------- ---------- ---------- ---------- ---------- ----------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' -------------------------- ---------- ---------- ---------- ---------- ----------
Dim blnReturn As Boolean
Dim blnSwap As Boolean
Dim lngLow As Long
Dim lngHigh As Long
Dim lngPivot As Long
Dim lngPosLow As Long
Dim lngPosHigh As Long
Dim strPivot As Variant
On Error GoTo Err_blnQuick_Sort_Strings
blnReturn = False
lngLow = IIf(lngLow_Value > -1&, lngLow_Value, LBound(strArray))
lngHigh = IIf(lngHigh_Value > -1&, lngHigh_Value, UBound(strArray))
If lngLow >= lngHigh Then
blnQuick_Sort_Strings = True
Exit Function
End If
' If only 2 elements in this subdivision; swap them if out of order...
If (lngHigh - lngLow) = 1& Then
If (blnAlpha_Sort) Then
blnSwap = (strArray(lngLow) > strArray(lngHigh))
Else
blnSwap = (Val(strArray(lngLow)) > Val(strArray(lngHigh)))
End If
If (blnSwap) Then
Call strSwap(strArray(lngLow), strArray(lngHigh))
End If
blnQuick_Sort_Strings = True
Exit Function
End If
' Pick a pivot element at random & move it to the end...
lngPivot = CLng(Int(Rnd(1) * (lngHigh - lngLow) + 1&) + lngLow)
Call strSwap(strArray(lngHigh), strArray(lngPivot))
strPivot = UCase$(strArray(lngHigh))
Do
lngPosLow = lngLow
lngPosHigh = lngHigh
' Move in from both sides towards the pivot element...
If (blnAlpha_Sort) Then
Do While (lngPosLow < lngPosHigh) And (UCase$(strArray(lngPosLow )) <= strPivot)
lngPosLow = lngPosLow + 1&
Loop
Do While (lngPosHigh > lngPosLow) And (UCase$(strArray(lngPosHig h)) >= strPivot)
lngPosHigh = lngPosHigh - 1&
Loop
Else
Do While (lngPosLow < lngPosHigh) And (Val(strArray(lngPosLow)) <= Val(strPivot))
lngPosLow = lngPosLow + 1&
Loop
Do While (lngPosHigh > lngPosLow) And (Val(strArray(lngPosHigh)) >= Val(strPivot))
lngPosHigh = lngPosHigh - 1&
Loop
End If
' If we haven't reached the pivot element then two elements on either side are out of order & need swapping...
If lngPosLow < lngPosHigh Then
Call strSwap(strArray(lngPosLow ), strArray(lngPosHigh))
End If
Loop While (lngPosLow < lngPosHigh)
' Move the pivot element back to its proper place in the array...
Call strSwap(strArray(lngPosLow ), strArray(lngHigh))
' Recursively call the Sort procedure (pass the smaller subdivision first to use less stack space)...
blnReturn = True
If (lngPosLow - lngLow) < (lngHigh - lngPosLow) Then
blnReturn = blnQuick_Sort_Strings(strA rray(), lngLow, lngPosLow - 1&, blnAlpha_Sort)
If (blnReturn) Then
blnReturn = blnQuick_Sort_Strings(strA rray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
End If
Else
blnReturn = blnQuick_Sort_Strings(strA rray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
If (blnReturn) Then
blnReturn = blnQuick_Sort_Strings(strA rray(), lngLow, lngPosLow - 1&, blnAlpha_Sort)
End If
End If
Exit_blnQuick_Sort_Strings :
On Error Resume Next
blnQuick_Sort_Strings = blnReturn
Exit Function
Err_blnQuick_Sort_Strings:
blnReturn = False
Resume Exit_blnQuick_Sort_Strings
End Function
Private Sub strSwap(ByRef strFirst As String, _
ByRef strSecond As String)
' -------------------------- ---------- ---------- ---------- ---------- ----------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' -------------------------- ---------- ---------- ---------- ---------- ----------
Dim strTemp As String
On Error Resume Next
strTemp = strSecond
strSecond = strFirst
strFirst = strTemp
End Sub
BFN,
fp.
Just to be clear, please use this code (and remove all existing code):
Public Sub Sort_Column_A_to_C()
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row
objCell.Resize(1&, 3) = vntSplit
Next objCell
End If
End Sub
Public Sub Sort_Column_A_to_C_Retain_
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim objCell As Range
Dim strArray() As String
Dim vntSplit As Variant
On Error Resume Next
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell & vbTab & objCell.Offset(, 1&) & vbTab & objCell.Offset(, 2&)
Next objCell
If (blnQuick_Sort_Strings(str
For Each objCell In Intersect([A2:A65536], ActiveSheet.UsedRange)
vntSplit = Split(strArray(objCell.Row
objCell = vntSplit(0)
objCell.Offset(, 1) = vntSplit(1)
objCell.Offset(, 2) = vntSplit(2)
Next objCell
End If
End Sub
Private Function blnQuick_Sort_Strings(ByRe
Optional ByRef lngLow_Value As Long = -1&, _
Optional ByRef lngHigh_Value As Long = -1&, _
Optional ByVal blnAlpha_Sort As Boolean = True) As Boolean
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim blnReturn As Boolean
Dim blnSwap As Boolean
Dim lngLow As Long
Dim lngHigh As Long
Dim lngPivot As Long
Dim lngPosLow As Long
Dim lngPosHigh As Long
Dim strPivot As Variant
On Error GoTo Err_blnQuick_Sort_Strings
blnReturn = False
lngLow = IIf(lngLow_Value > -1&, lngLow_Value, LBound(strArray))
lngHigh = IIf(lngHigh_Value > -1&, lngHigh_Value, UBound(strArray))
If lngLow >= lngHigh Then
blnQuick_Sort_Strings = True
Exit Function
End If
' If only 2 elements in this subdivision; swap them if out of order...
If (lngHigh - lngLow) = 1& Then
If (blnAlpha_Sort) Then
blnSwap = (strArray(lngLow) > strArray(lngHigh))
Else
blnSwap = (Val(strArray(lngLow)) > Val(strArray(lngHigh)))
End If
If (blnSwap) Then
Call strSwap(strArray(lngLow), strArray(lngHigh))
End If
blnQuick_Sort_Strings = True
Exit Function
End If
' Pick a pivot element at random & move it to the end...
lngPivot = CLng(Int(Rnd(1) * (lngHigh - lngLow) + 1&) + lngLow)
Call strSwap(strArray(lngHigh),
strPivot = UCase$(strArray(lngHigh))
Do
lngPosLow = lngLow
lngPosHigh = lngHigh
' Move in from both sides towards the pivot element...
If (blnAlpha_Sort) Then
Do While (lngPosLow < lngPosHigh) And (UCase$(strArray(lngPosLow
lngPosLow = lngPosLow + 1&
Loop
Do While (lngPosHigh > lngPosLow) And (UCase$(strArray(lngPosHig
lngPosHigh = lngPosHigh - 1&
Loop
Else
Do While (lngPosLow < lngPosHigh) And (Val(strArray(lngPosLow)) <= Val(strPivot))
lngPosLow = lngPosLow + 1&
Loop
Do While (lngPosHigh > lngPosLow) And (Val(strArray(lngPosHigh))
lngPosHigh = lngPosHigh - 1&
Loop
End If
' If we haven't reached the pivot element then two elements on either side are out of order & need swapping...
If lngPosLow < lngPosHigh Then
Call strSwap(strArray(lngPosLow
End If
Loop While (lngPosLow < lngPosHigh)
' Move the pivot element back to its proper place in the array...
Call strSwap(strArray(lngPosLow
' Recursively call the Sort procedure (pass the smaller subdivision first to use less stack space)...
blnReturn = True
If (lngPosLow - lngLow) < (lngHigh - lngPosLow) Then
blnReturn = blnQuick_Sort_Strings(strA
If (blnReturn) Then
blnReturn = blnQuick_Sort_Strings(strA
End If
Else
blnReturn = blnQuick_Sort_Strings(strA
If (blnReturn) Then
blnReturn = blnQuick_Sort_Strings(strA
End If
End If
Exit_blnQuick_Sort_Strings
On Error Resume Next
blnQuick_Sort_Strings = blnReturn
Exit Function
Err_blnQuick_Sort_Strings:
blnReturn = False
Resume Exit_blnQuick_Sort_Strings
End Function
Private Sub strSwap(ByRef strFirst As String, _
ByRef strSecond As String)
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim strTemp As String
On Error Resume Next
strTemp = strSecond
strSecond = strFirst
strFirst = strTemp
End Sub
BFN,
fp.
ASKER
fp,
thats great, one last thing
this is areport that i generate every month. is there a way that the macro can be place in my pc and the click on it and run it on any excel spreadsheet that i have with the sme format bt different values in coulmn c
thats great, one last thing
this is areport that i generate every month. is there a way that the macro can be place in my pc and the click on it and run it on any excel spreadsheet that i have with the sme format bt different values in coulmn c
Hi,
Create a new workbook, say "Sorting.xls", that contains the code & place this in your XLStart folder:
C:\Program Files\Microsoft Office\OFFICE11\XLSTART
Close MS-Excel, then open another workbook.
The "macro" (VBA code) will be available to use as required.
PS. I was confused about your comment regarding "different values in column c".
BFN,
fp.
Create a new workbook, say "Sorting.xls", that contains the code & place this in your XLStart folder:
C:\Program Files\Microsoft Office\OFFICE11\XLSTART
Close MS-Excel, then open another workbook.
The "macro" (VBA code) will be available to use as required.
PS. I was confused about your comment regarding "different values in column c".
BFN,
fp.
ASKER
the changes in column c are $ amounts that vary month on month
the problem with the XL start is that every time i open excel that file opens
the problem with the XL start is that every time i open excel that file opens
Thanks for clarifying column C.
Yes, that's correct, everytime MS-Excel starts the file is opened & is therefore available to use.
Another alternative is to create an Add-in.
Here's some details on this provided by Microsoft:
[ http://support.microsoft.com/?kbid=211563 ]
BFN,
fp.
Yes, that's correct, everytime MS-Excel starts the file is opened & is therefore available to use.
Another alternative is to create an Add-in.
Here's some details on this provided by Microsoft:
[ http://support.microsoft.com/?kbid=211563 ]
BFN,
fp.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Are you familiar with inserting VBA code in your workbooks?
Right-click any sheet within the appropriate workbook, and select "View Code" from the pop-menu displayed.
When the "Microsoft Visual Basic" environment is displayed, look for a window named "Project - VBAProject"; if it is not shown, depress & hold down the [CTRL] key, press & release the [R] key, then release the [CTRL] key.
Locate the entry in the "Project - VBAProject" window for "VBAProject (<name of your .xls file>", and right-click it.
Select "Insert->" then "Module" from the menu displayed, and then paste the following into the code window (most probably "Module1", but may be "Module" followed by a number) that is then shown:
' Start of Code...
Option Explicit
Public Sub Sort_Column_A()
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim objCell As Range
Dim strArray() As String
On Error Resume Next
For Each objCell In Intersect([A:A], ActiveSheet.UsedRange)
ReDim Preserve strArray(objCell.Row) As String
strArray(objCell.Row) = objCell
Next objCell
If (blnQuick_Sort_Strings(str
For Each objCell In Intersect([A:A], ActiveSheet.UsedRange)
objCell = strArray(objCell.Row)
Next objCell
End If
End Sub
Private Function blnQuick_Sort_Strings(ByRe
Optional ByRef lngLow_Value As Long = -1&, _
Optional ByRef lngHigh_Value As Long = -1&, _
Optional ByVal blnAlpha_Sort As Boolean = True) As Boolean
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim blnReturn As Boolean
Dim blnSwap As Boolean
Dim lngLow As Long
Dim lngHigh As Long
Dim lngPivot As Long
Dim lngPosLow As Long
Dim lngPosHigh As Long
Dim strPivot As Variant
On Error GoTo Err_blnQuick_Sort_Strings
blnReturn = False
lngLow = IIf(lngLow_Value > -1&, lngLow_Value, LBound(strArray))
lngHigh = IIf(lngHigh_Value > -1&, lngHigh_Value, UBound(strArray))
If lngLow >= lngHigh Then
blnQuick_Sort_Strings = True
Exit Function
End If
' If only 2 elements in this subdivision; swap them if out of order...
If (lngHigh - lngLow) = 1& Then
If (blnAlpha_Sort) Then
blnSwap = (strArray(lngLow) > strArray(lngHigh))
Else
blnSwap = (Val(strArray(lngLow)) > Val(strArray(lngHigh)))
End If
If (blnSwap) Then
Call strSwap(strArray(lngLow), strArray(lngHigh))
End If
blnQuick_Sort_Strings = True
Exit Function
End If
' Pick a pivot element at random & move it to the end...
lngPivot = CLng(Int(Rnd(1) * (lngHigh - lngLow) + 1&) + lngLow)
Call strSwap(strArray(lngHigh),
strPivot = UCase$(strArray(lngHigh))
Do
lngPosLow = lngLow
lngPosHigh = lngHigh
' Move in from both sides towards the pivot element...
If (blnAlpha_Sort) Then
Do While (lngPosLow < lngPosHigh) And (UCase$(strArray(lngPosLow
lngPosLow = lngPosLow + 1&
Loop
Do While (lngPosHigh > lngPosLow) And (UCase$(strArray(lngPosHig
lngPosHigh = lngPosHigh - 1&
Loop
Else
Do While (lngPosLow < lngPosHigh) And (Val(strArray(lngPosLow)) <= Val(strPivot))
lngPosLow = lngPosLow + 1&
Loop
Do While (lngPosHigh > lngPosLow) And (Val(strArray(lngPosHigh))
lngPosHigh = lngPosHigh - 1&
Loop
End If
' If we haven't reached the pivot element then two elements on either side are out of order & need swapping...
If lngPosLow < lngPosHigh Then
Call strSwap(strArray(lngPosLow
End If
Loop While (lngPosLow < lngPosHigh)
' Move the pivot element back to its proper place in the array...
Call strSwap(strArray(lngPosLow
' Recursively call the Sort procedure (pass the smaller subdivision first to use less stack space)...
blnReturn = True
If (lngPosLow - lngLow) < (lngHigh - lngPosLow) Then
blnReturn = blnQuick_Sort_Strings(strA
If (blnReturn) Then
blnReturn = blnQuick_Sort_Strings(strA
End If
Else
blnReturn = blnQuick_Sort_Strings(strA
If (blnReturn) Then
blnReturn = blnQuick_Sort_Strings(strA
End If
End If
Exit_blnQuick_Sort_Strings
On Error Resume Next
blnQuick_Sort_Strings = blnReturn
Exit Function
Err_blnQuick_Sort_Strings:
blnReturn = False
Resume Exit_blnQuick_Sort_Strings
End Function
Private Sub strSwap(ByRef strFirst As String, _
ByRef strSecond As String)
' --------------------------
' Experts Exchange Question:
' Home \ All Topics \ Applications \ MS Office \ Excel
' https://www.experts-exchange.com/questions/21601371/sorting.html
' Sorting
'
' Copyright (c) 2005 Clearlogic Concepts (UK) Limited
' N.Lee [ http://NigelLee.info ] - 20 October 2005
' --------------------------
Dim strTemp As String
On Error Resume Next
strTemp = strSecond
strSecond = strFirst
strFirst = strTemp
End Sub
' ...End of Code
Now depress & hold the [ALT] key, press & release [F11], then release the [ALT] key.
Save your workbook (to make sure the code is saved).
When you wish to run the code, hold the [ALT] key, press & release [F8], then release the [ALT] key.
Select "Sort_Column_A" from the list displayed in the "Macro" dialog window, and click [Run].
BFN,
fp.