Re: [ExcelVBA] Sorting

 

As promised a while ago in the Sorting in VBA thread, here is my solution for sorting on multiple Elements of a two dimensional array. It seems to give the same results as Excel .... so far!

Please note that there's a link to the original merge sort code!

I'm including a proc to generate random strings at the bottom as a "bonus".

I'm using all of this and much more in a project to update code in various ways. The project is hosted by the codecage forum. Registration is free and I've just uploaded the latest version.

If you're interested and for some reason don't want to register there... though I can fully recomend it... please get back to me. If there is enough interest I'll post it on the site for download.

Lisa

Sub subArrayMergeSort( _
ByRef vpArray As Variant, _
ByVal lngpElement As Long, _
Optional vpMirror As Variant, _
Optional ByVal lngpLeft As Long, _
Optional ByVal lngpRight As Long _
)
' http://www.vbforums.com/showthread.php?t=473677
'
' Recurse Merge Sort a TWO Dim array.
'
' Use...
' subMergeSort Array, Element
'
' lngpLeft and lngpRight are 0 at the start.
'
' Sorts on ONE element.
'

Dim lnglLeftStart As Long
Dim lnglMid As Long
Dim lnglOutputStart As Long
Dim lnglRightStart As Long
Dim vlSwap As Variant
Dim lnglCElement As Long
Dim lnglNumElements As Long
Dim vlSwapRow() As Variant

lnglNumElements = UBound(vpArray, 2)
ReDim vlSwapRow(lnglNumElements)

If lngpRight = 0 Then
lngpLeft = LBound(vpArray, 1)
lngpRight = UBound(vpArray, 1)
ReDim vpMirror(lngpLeft To lngpRight, 0 To lnglNumElements)
End If

lnglMid = lngpRight - lngpLeft

Select Case lnglMid
Case 0
Case 1

' Changed this to make it case insensitive.
' If vpArray(lngpLeft) > vpArray(lngpRight) Then
If StrComp( _
vpArray(lngpLeft, lngpElement), _
vpArray(lngpRight, lngpElement), _
vbTextCompare) _
= 1 _
Then

' SWAP the whole row.
For lnglCElement = 0 To lnglNumElements
vlSwapRow(lnglCElement) = vpArray(lngpLeft, lnglCElement)
Next lnglCElement

For lnglCElement = 0 To lnglNumElements
vpArray(lngpLeft, lnglCElement) = vpArray(lngpRight, lnglCElement)
Next lnglCElement

For lnglCElement = 0 To lnglNumElements
vpArray(lngpRight, lnglCElement) = vlSwapRow(lnglCElement)
Next lnglCElement

' vlSwap = vpArray(lngpLeft)
' vpArray(lngpLeft) = vpArray(lngpRight)
' vpArray(lngpRight) = vlSwap

End If
Case Else

lnglMid = lnglMid \ 2 + lngpLeft
subArrayMergeSort vpArray, lngpElement, vpMirror, lngpLeft, lnglMid
subArrayMergeSort vpArray, lngpElement, vpMirror, lnglMid + 1, lngpRight
' Merge the resulting halves

lnglLeftStart = lngpLeft ' start of first (left) half
lnglRightStart = lnglMid + 1 ' start of second (right) half
lnglOutputStart = lngpLeft ' start of output (mirror array)

Do

' Changed this to make it case insensitive.
' If vpArray(lnglRightStart) < vpArray(lnglLeftStart) Then
If StrComp( _
vpArray(lnglRightStart, lngpElement), _
vpArray(lnglLeftStart, lngpElement), _
vbTextCompare) = _
-1 _
Then

' COPY the complete row.
' vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
Next lnglCElement


lnglRightStart = lnglRightStart + 1
If lnglRightStart > lngpRight Then
For lnglLeftStart = lnglLeftStart To lnglMid
lnglOutputStart = lnglOutputStart + 1

' COPY the whole row.
' vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
Next lnglCElement

Next
Exit Do
End If
Else

' COPY the complete row.
' vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
Next lnglCElement


lnglLeftStart = lnglLeftStart + 1
If lnglLeftStart > lnglMid Then
For lnglRightStart = lnglRightStart To lngpRight
lnglOutputStart = lnglOutputStart + 1

' COPY the complete row.
' vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
For lnglCElement = 0 To lnglNumElements
vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
Next lnglCElement

Next

Exit Do
End If
End If

lnglOutputStart = lnglOutputStart + 1

Loop
For lnglOutputStart = lngpLeft To lngpRight

' Swap the complete row.
' vpArray(lnglOutputStart) = vpMirror(lnglOutputStart)
For lnglCElement = 0 To lnglNumElements
vpArray(lnglOutputStart, lnglCElement) = vpMirror(lnglOutputStart, lnglCElement)
Next lnglCElement

Next
End Select
' *********************************************************************
End Sub
Sub subSortMultiElements( _
spArray() As String, _
spOrder As String _
)
' Sort a STRING array with 2 dimensions.
' Assume Sort on the 2nd Dimension
' so assumes it IS a 2 Dim array.
' Sort on more than one element.
'
' This uses a merge sort.
' Go through the sort keys IN REVERSE ORDER!
'
' The sort is set up as ascending and not case sensitive.
'
' Use
' subSortMultiElements Array, Order
'
' Ex Order = "1 4 0 3 2".
' Not all elements need be specified.
' Any delimiter may be used.
'

Dim ilN As Integer
Dim ilNumSortKeys As Integer
Dim slOrder As String
Dim slOrderArray() As String

' Make an Order Array.
slOrder = spOrder

' Delimiter?
' Disappear the numbers.
For ilN = 0 To 9
slOrder = Replace(slOrder, CStr(ilN), "")
Next ilN
slOrder = Trim(slOrder)

' Should only have the delimiter left.
If Len(slOrder) = 0 Then
slOrderArray = Split(spOrder, " ")
Else
slOrderArray = Split(spOrder, Mid(slOrder, 1, 1))
End If

ilNumSortKeys = UBound(slOrderArray)
For ilN = ilNumSortKeys To 0 Step -1
subArrayMergeSort spArray, slOrderArray(ilN)
Next ilN

' ***********************************************************************
End Sub
Function fncGetRandomString() As String
' Generate a random string.
'
'

Dim ilN As Integer
Dim ilRLen As Integer
Dim slChar As String
Dim slOptions As String
Dim slResult As String
Dim ilOptionsChr As Integer
Dim ilLenOptions As Integer
Dim ilSanityCheck As Integer
Dim ilMaxLen As Integer
Dim ilDefaultLen As Integer
Dim ilMaxLoops As Integer

ilMaxLoops = 30
ilDefaultLen = 5
ilMaxLen = 10
slOptions = "0123456789"
slOptions = slOptions & "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
slOptions = slOptions & "abcdefghijklmnopqrstuvwxyz"
ilLenOptions = Len(slOptions)

' Generate a random length.
ilSanityCheck = 0
Do
ilRLen = Int(Rnd * 100)
If ilRLen > 0 Then
If ilRLen < ilMaxLen Then
Exit Do
End If
End If

ilSanityCheck = ilSanityCheck + 1
If ilSanityCheck > ilMaxLoops Then
ilRLen = ilDefaultLen
Exit Do
End If
Loop

For ilN = 0 To ilRLen
' Select a random char from options.

' Generate a random number within the length of options.
ilSanityCheck = 0
Do
ilOptionsChr = Int(Rnd * 100)
If ilOptionsChr > 0 Then
If ilOptionsChr <= ilLenOptions Then
Exit Do
End If
End If

ilSanityCheck = ilSanityCheck + 1
If ilSanityCheck > ilMaxLoops Then
ilOptionsChr = 20
Exit Do
End If
Loop

slChar = Mid$(slOptions, ilOptionsChr, 1)

' Add the character to the result string.
slResult = slResult & slChar
Next ilN

fncGetRandomString = slResult
' ***********************************************************************
End Function

[Non-text portions of this message have been removed]

__._,_.___

Reply to sender | Reply to group | Reply via web post | Start a New Topic

Messages in this topic (12)

Recent Activity:

• New Members 4

Visit Your Group

----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

----------------------------------

Switch to: Text-Only, Daily Digest • Unsubscribe • Terms of Use

.

__,_._,___