Announcement

Collapse
No announcement yet.

VBA Merge sort

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • VBA Merge sort



    I don't know if this will help anybody, nor can I be sure this code is bullet proof, but what I can say is that I use it an awful lot to quickly sort arrays in VBA and I haven't broken it yet. Could be useful?
    Nb. this mutates the original array so make a copy of your array first if you want one with the original order in place.

    Code:
    'Sorts a one or two dimensional array.
    '2 dimensional arrays can have their sort keys specified by passing
    'the appropriate column number(s) as the sortKeys parameter.
    'Function passes a reference so will mutate your original array.
    'If this is not desirable you must pass a copy.
    '
    'Example uses:
    '  sortArray myArray                 - One-dimensional array
    '  sortArray myArray, 2              - Two-dimensional array, single sort key
    '  sortArray myArray, Array(2,3,1)   - Two-dimensional array, multiple sort keys
    '  sortArray myArray, Array(2,3,1), True   - Two-dimensional array, multiple sort keys with headers preserved
    Function UTIL_sortArray(ByRef arr As Variant, Optional ByRef sortKeys As Variant = Null, Optional ByVal hasHeaders As Boolean = False)
        Dim mid As Long
        Dim i As Long
        Dim j As Long
        Dim k As Long
        Dim x As Long
        Dim y As Long
        Dim sortMode As Long
        Dim arr1
        Dim arr2
        Dim head
        Dim tmp
        
        If UBound(arr) - LBound(arr) = 0 Then Exit Function
        On Error Resume Next
        i = UBound(arr, 2)
        If Err.Number <> 0 Then
            sortMode = 1 'Not a 2D array
            If hasHeaders Then
                ReDim tmp(LBound(arr) To UBound(arr) - 1)
                ReDim head(1 To 1)
                For i = LBound(arr) To UBound(arr)
                    If i = LBound(arr) Then
                        head(1) = arr(LBound(arr))
                    Else
                        tmp(i - 1) = arr(i)
                    End If
                Next i
                arr = tmp
            End If
        Else
            sortMode = 2
            If hasHeaders Then
                ReDim tmp(LBound(arr) To (UBound(arr) - 1), LBound(arr, 2) To UBound(arr, 2))
                ReDim head(1 To 1, LBound(arr, 2) To UBound(arr, 2))
                For i = LBound(arr) To UBound(arr)
                    For j = LBound(arr, 2) To UBound(arr, 2)
                        If i = LBound(arr) Then
                            head(1, j) = arr(LBound(arr), j)
                        Else
                            tmp(i - 1, j) = arr(i, j)
                        End If
                    Next j
                Next i
                arr = tmp
            End If
        End If
        
        On Error GoTo 0
        If IsNumeric(sortKeys) Then
            sortKeys = Array(CLng(sortKeys))
        ElseIf IsNull(sortKeys) Then
            sortKeys = Array(LBound(arr))
        End If
        y = LBound(sortKeys)
        mid = Int((UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) / 2)
        If mid < LBound(arr) Then mid = LBound(arr)
        If sortMode = 1 Then
            ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0))
            ReDim arr2(LBound(arr) To UBound(arr) - mid)
            j = LBound(arr)
            For i = LBound(arr1) To UBound(arr1)
                arr1(i) = arr(j)
                j = j + 1
            Next i
            For i = LBound(arr2) To UBound(arr2)
                arr2(i) = arr(j)
                j = j + 1
            Next i
        ElseIf sortMode = 2 Then
            ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0), LBound(arr, 2) To UBound(arr, 2))
            ReDim arr2(LBound(arr) To UBound(arr) - mid, LBound(arr, 2) To UBound(arr, 2))
            j = LBound(arr)
            For i = LBound(arr1) To UBound(arr1)
                For k = LBound(arr1, 2) To UBound(arr1, 2)
                    arr1(i, k) = arr(j, k)
                Next k
                j = j + 1
            Next i
            For i = LBound(arr2) To UBound(arr2)
                For k = LBound(arr2, 2) To UBound(arr2, 2)
                    arr2(i, k) = arr(j, k)
                Next k
                j = j + 1
            Next i
        End If
        UTIL_sortArray arr1, sortKeys 'I call myself!!!
        UTIL_sortArray arr2, sortKeys 'I call myself again!!!
        i = LBound(arr)
        j = LBound(arr1)
        k = LBound(arr2)
        If sortMode = 1 Then
            While j <= UBound(arr1) And k <= UBound(arr2)
                If arr1(j) <= arr2(k) Then
                    arr(i) = arr1(j)
                    j = j + 1
                Else
                    arr(i) = arr2(k)
                    k = k + 1
                End If
                i = i + 1
            Wend
            While j <= UBound(arr1)
                arr(i) = arr1(j)
                j = j + 1
                i = i + 1
            Wend
            While k <= UBound(arr2)
                arr(i) = arr2(k)
                k = k + 1
                i = i + 1
            Wend
        ElseIf sortMode = 2 Then
            While j <= UBound(arr1) And k <= UBound(arr2)
                If arr1(j, sortKeys(y)) < arr2(k, sortKeys(y)) _
                        Or (arr1(j, sortKeys(y)) = arr2(k, sortKeys(y)) And UBound(sortKeys) = y) Then
                    For x = LBound(arr1, 2) To UBound(arr1, 2)
                        arr(i, x) = arr1(j, x)
                    Next x
                    j = j + 1
                    y = LBound(sortKeys)
                ElseIf arr1(j, sortKeys(y)) > arr2(k, sortKeys(y)) Then
                    For x = LBound(arr2, 2) To UBound(arr2, 2)
                        arr(i, x) = arr2(k, x)
                    Next x
                    k = k + 1
                    y = LBound(sortKeys)
                Else
                    i = i - 1
                    y = y + 1
                End If
                i = i + 1
            Wend
            While j <= UBound(arr1)
                For x = LBound(arr1, 2) To UBound(arr1, 2)
                    arr(i, x) = arr1(j, x)
                Next x
                j = j + 1
                i = i + 1
            Wend
            While k <= UBound(arr2)
                For x = LBound(arr2, 2) To UBound(arr2, 2)
                    arr(i, x) = arr2(k, x)
                Next x
                k = k + 1
                i = i + 1
            Wend
        End If
        If hasHeaders Then
            If sortMode = 1 Then
                '1d
                ReDim tmp(LBound(tmp) To UBound(tmp) + 1)
                tmp(LBound(tmp)) = head(1)
                For i = LBound(arr) To UBound(arr)
                    tmp(i + 1) = arr(i)
                Next i
            Else
                '2d
                ReDim tmp(LBound(tmp) To UBound(tmp) + 1, LBound(tmp, 2) To UBound(tmp, 2))
                For i = LBound(tmp) To UBound(tmp)
                    For j = LBound(tmp, 2) To UBound(tmp, 2)
                        If i = LBound(tmp) Then
                            tmp(i, j) = head(1, j)
                        Else
                            tmp(i, j) = arr(i - 1, j)
                        End If
                    Next
                Next i
            End If
            arr = tmp
        End If
    End Function

  • #2
    Neat code, thanks
    We now have a reputation system in place. If my reply helped please "Like" the reply by clicking the "Like" icon at bottom right of my reply.

    Comment


    • #3
      Cheers KjBox. I find it useful at least!

      Comment


      • #4
        Hmmmm... wish I had seen this yesterday... LOL. Iíll try it out later.
        Check out our new reputation system. Click on the Like button under the post!
        _______________________________________________

        There are 10 types of people in the world. Those that understand Binary and those that dont.

        Why are Halloween and Christmas the same? Because Oct 31 = Dec 25...

        The BEST Lookup function of all time

        Dynamic Named Ranges are your bestest friend

        _______________________________________________

        Comment


        • #5
          Awesome sauce... very very quick for me on a 2D x 1 column sort with numbers. over 40k rows.. suggestion for improvement... add another optional parameter for ascending or descending... not sure how badly that would screw up the code. Or maybe include instructions to convert between one and the other. I guess its a case of changing all < with > ? Thanks mate.

          Ger
          Check out our new reputation system. Click on the Like button under the post!
          _______________________________________________

          There are 10 types of people in the world. Those that understand Binary and those that dont.

          Why are Halloween and Christmas the same? Because Oct 31 = Dec 25...

          The BEST Lookup function of all time

          Dynamic Named Ranges are your bestest friend

          _______________________________________________

          Comment


          • #6
            That's actually a very good idea! I have a reverse array function which I've always used when I wanted to sort in reverse, but it makes so much more sense to have an ascending/descending flag. I'll get on it!

            Comment


            • #7


              There is definitely a more efficient way of doing this, but here's a quick and dirty version with a descending flag as the last optional argument to sort an array in descending order. Just set it to true to take effect.

              Code:
              'Sorts a one or two dimensional array.
              '2 dimensional arrays can have their sort keys specified by passing
              'the appropriate column number(s) as the sortKeys parameter.
              'Function passes a reference so will mutate your original array.
              'If this is not desirable you must pass a copy.
              '
              'Example uses:
              '  sortArray myArray                 - One-dimensional array
              '  sortArray myArray, 2              - Two-dimensional array, single sort key
              '  sortArray myArray, Array(2,3,1)   - Two-dimensional array, multiple sort keys
              '  sortArray myArray, Array(2,3,1), True   - Two-dimensional array, multiple sort keys with headers preserved
              Function UTIL_sortArray(ByRef arr As Variant, Optional ByRef sortKeys As Variant = Null, Optional ByVal hasHeaders As Boolean = False, Optional ByVal descending As Boolean = False)
                  Dim mid As Long
                  Dim i As Long
                  Dim j As Long
                  Dim k As Long
                  Dim x As Long
                  Dim y As Long
                  Dim sortMode As Long
                  Dim arr1
                  Dim arr2
                  Dim head
                  Dim tmp
                  
                  If UBound(arr) - LBound(arr) = 0 Then Exit Function
                  On Error Resume Next
                  i = UBound(arr, 2)
                  If Err.Number <> 0 Then
                      sortMode = 1 'Not a 2D array
                      If hasHeaders Then
                          ReDim tmp(LBound(arr) To UBound(arr) - 1)
                          ReDim head(1 To 1)
                          For i = LBound(arr) To UBound(arr)
                              If i = LBound(arr) Then
                                  head(1) = arr(LBound(arr))
                              Else
                                  tmp(i - 1) = arr(i)
                              End If
                          Next i
                          arr = tmp
                      End If
                  Else
                      sortMode = 2
                      If hasHeaders Then
                          ReDim tmp(LBound(arr) To (UBound(arr) - 1), LBound(arr, 2) To UBound(arr, 2))
                          ReDim head(1 To 1, LBound(arr, 2) To UBound(arr, 2))
                          For i = LBound(arr) To UBound(arr)
                              For j = LBound(arr, 2) To UBound(arr, 2)
                                  If i = LBound(arr) Then
                                      head(1, j) = arr(LBound(arr), j)
                                  Else
                                      tmp(i - 1, j) = arr(i, j)
                                  End If
                              Next j
                          Next i
                          arr = tmp
                      End If
                  End If
                  
                  On Error GoTo 0
                  If IsNumeric(sortKeys) Then
                      sortKeys = Array(CLng(sortKeys))
                  ElseIf IsNull(sortKeys) Then
                      sortKeys = Array(LBound(arr))
                  End If
                  y = LBound(sortKeys)
                  mid = Int((UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) / 2)
                  If mid < LBound(arr) Then mid = LBound(arr)
                  If sortMode = 1 Then
                      ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0))
                      ReDim arr2(LBound(arr) To UBound(arr) - mid)
                      j = LBound(arr)
                      For i = LBound(arr1) To UBound(arr1)
                          arr1(i) = arr(j)
                          j = j + 1
                      Next i
                      For i = LBound(arr2) To UBound(arr2)
                          arr2(i) = arr(j)
                          j = j + 1
                      Next i
                  ElseIf sortMode = 2 Then
                      ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0), LBound(arr, 2) To UBound(arr, 2))
                      ReDim arr2(LBound(arr) To UBound(arr) - mid, LBound(arr, 2) To UBound(arr, 2))
                      j = LBound(arr)
                      For i = LBound(arr1) To UBound(arr1)
                          For k = LBound(arr1, 2) To UBound(arr1, 2)
                              arr1(i, k) = arr(j, k)
                          Next k
                          j = j + 1
                      Next i
                      For i = LBound(arr2) To UBound(arr2)
                          For k = LBound(arr2, 2) To UBound(arr2, 2)
                              arr2(i, k) = arr(j, k)
                          Next k
                          j = j + 1
                      Next i
                  End If
                  UTIL_sortArray arr1, sortKeys 'I call myself!!!
                  UTIL_sortArray arr2, sortKeys 'I call myself again!!!
                  i = LBound(arr)
                  j = LBound(arr1)
                  k = LBound(arr2)
                  If sortMode = 1 Then
                      While j <= UBound(arr1) And k <= UBound(arr2)
                          If arr1(j) <= arr2(k) Then
                              arr(i) = arr1(j)
                              j = j + 1
                          Else
                              arr(i) = arr2(k)
                              k = k + 1
                          End If
                          i = i + 1
                      Wend
                      While j <= UBound(arr1)
                          arr(i) = arr1(j)
                          j = j + 1
                          i = i + 1
                      Wend
                      While k <= UBound(arr2)
                          arr(i) = arr2(k)
                          k = k + 1
                          i = i + 1
                      Wend
                  ElseIf sortMode = 2 Then
                      While j <= UBound(arr1) And k <= UBound(arr2)
                          If arr1(j, sortKeys(y)) < arr2(k, sortKeys(y)) _
                                  Or (arr1(j, sortKeys(y)) = arr2(k, sortKeys(y)) And UBound(sortKeys) = y) Then
                              For x = LBound(arr1, 2) To UBound(arr1, 2)
                                  arr(i, x) = arr1(j, x)
                              Next x
                              j = j + 1
                              y = LBound(sortKeys)
                          ElseIf arr1(j, sortKeys(y)) > arr2(k, sortKeys(y)) Then
                              For x = LBound(arr2, 2) To UBound(arr2, 2)
                                  arr(i, x) = arr2(k, x)
                              Next x
                              k = k + 1
                              y = LBound(sortKeys)
                          Else
                              i = i - 1
                              y = y + 1
                          End If
                          i = i + 1
                      Wend
                      While j <= UBound(arr1)
                          For x = LBound(arr1, 2) To UBound(arr1, 2)
                              arr(i, x) = arr1(j, x)
                          Next x
                          j = j + 1
                          i = i + 1
                      Wend
                      While k <= UBound(arr2)
                          For x = LBound(arr2, 2) To UBound(arr2, 2)
                              arr(i, x) = arr2(k, x)
                          Next x
                          k = k + 1
                          i = i + 1
                      Wend
                  End If
                  If descending And (UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) > 1 Then
                      If sortMode = 1 Then
                          ReDim tmp(LBound(arr) To UBound(arr))
                          For i = LBound(arr) To UBound(arr)
                              tmp(UBound(tmp) - (i - LBound(arr))) = arr(i)
                          Next i
                      ElseIf sortMode = 2 Then
                          ReDim tmp(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
                          For i = LBound(arr) To UBound(arr)
                              For j = LBound(arr, 2) To UBound(arr, 2)
                                  tmp(UBound(tmp) - (i - LBound(arr)), j) = arr(i, j)
                              Next j
                          Next i
                      End If
                      arr = tmp
                  End If
                  If hasHeaders Then
                      If sortMode = 1 Then
                          '1d
                          ReDim tmp(LBound(tmp) To UBound(tmp) + 1)
                          tmp(LBound(tmp)) = head(1)
                          For i = LBound(arr) To UBound(arr)
                              tmp(i + 1) = arr(i)
                          Next i
                      Else
                          '2d
                          ReDim tmp(LBound(tmp) To UBound(tmp) + 1, LBound(tmp, 2) To UBound(tmp, 2))
                          For i = LBound(tmp) To UBound(tmp)
                              For j = LBound(tmp, 2) To UBound(tmp, 2)
                                  If i = LBound(tmp) Then
                                      tmp(i, j) = head(1, j)
                                  Else
                                      tmp(i, j) = arr(i - 1, j)
                                  End If
                              Next
                          Next i
                      End If
                      arr = tmp
                  End If
              End Function

              Comment

              Working...
              X