Link to home
Start Free TrialLog in
Avatar of spirodem
spirodemFlag for Australia

asked on

sorting

in column a i have data that looks like this - 11k,11n,12p,55s,100,100a,101,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
Avatar of [ fanpages ]
[ fanpages ]

Hi,

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(strArray, , True)) Then
     For Each objCell In Intersect([A:A], ActiveSheet.UsedRange)
         objCell = strArray(objCell.Row)
     Next objCell
  End If
 
End Sub
Private Function blnQuick_Sort_Strings(ByRef 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(lngPosHigh)) >= 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(strArray(), lngLow, lngPosLow - 1&, blnAlpha_Sort)
     
     If (blnReturn) Then
         blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
     End If
  Else
     blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
     
     If (blnReturn) Then
        blnReturn = blnQuick_Sort_Strings(strArray(), 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

' ...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.
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
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.
Avatar of spirodem

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
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(strArray, , 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.
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(strArray, , 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.
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(strArray, , 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(strArray, , 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(ByRef 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(lngPosHigh)) >= 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(strArray(), lngLow, lngPosLow - 1&, blnAlpha_Sort)
     
     If (blnReturn) Then
         blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
     End If
  Else
     blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
     
     If (blnReturn) Then
        blnReturn = blnQuick_Sort_Strings(strArray(), 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.

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
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.
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
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.
ASKER CERTIFIED SOLUTION
Avatar of [ fanpages ]
[ fanpages ]

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Thanks for your grading.

BFN,

fp.
[ http://NigelLee.info ]