Merge Sort in VBA in MS Project

[brodaddy02]

I can't seem to get the merge sort working. I think it has something to do with CopyMemory function call. I am trying to use it in MS Project. Code works on a smaller test data, but my 27000 data array the code doesn't work. Code is taken from

http://www.vb-helper.com/howto_mergesort.html

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias _    "RtlMoveMemory" (destination As Date, source As Date, _
    ByVal length As Long)

Public Sub MergeSort(ByRef keyArray() As String, ByRef list() As Date, ByVal first_index As Long, ByVal last_index As Long)
    Dim middle As Long


    If (last_index > first_index) Then
        ' Recursively sort the two halves of the list.
        middle = (first_index + last_index) \ 2
        MergeSort keyArray, list, first_index, middle
        MergeSort keyArray, list, middle + 1, last_index


        ' Merge the results.
        Merge keyArray, list, first_index, middle, last_index
    End If
End Sub


' Merge two sorted sublists.
Public Sub Merge(ByRef keyArray() As String, ByRef list() As Date, ByVal beginning As Long, ByVal middle As Long, ByVal ending As Long)
    Dim temp_array() As Date  'holds temporary list data
    Dim temp_Key_Array() As String
    Dim temp As Long
    Dim counterA As Long
    Dim counterB As Long
    Dim counterMain As Long
    Dim i As Long


        ' Copy the array into a temporary array.
        ReDim temp_array(beginning To ending)
        ReDim temp_Key_Array(beginning To ending)
        CopyMemory temp_array(beginning), list(beginning), _
            (ending - beginning + 1) * Len(list(beginning))


        For i = beginning To ending
            temp_Key_Array(i) = keyArray(i)
        Next i

        ' counterA and counterB mark the next item to save
        ' in the first and second halves of the list.
        counterA = beginning
        counterB = middle + 1


        ' counterMain is the index where we will put the
        ' next item in the merged list.
        counterMain = beginning
        Do While (counterA <= middle) And (counterB <= ending)
            ' Find the smaller of the two items at the front
            ' of the two sublists.
            If (temp_array(counterA) <= temp_array(counterB)) _
                Then
                ' The smaller value is in the first half.
                list(counterMain) = temp_array(counterA)
                keyArray(counterMain) = temp_Key_Array(counterA)
                counterA = counterA + 1
            Else
                ' The smaller value is in the second half.
                list(counterMain) = temp_array(counterB)
                keyArray(counterMain) = temp_Key_Array(counterB)
                counterB = counterB + 1
            End If
            counterMain = counterMain + 1
        Loop


        ' Copy any remaining items from the first half.
        If counterA <= middle Then
            CopyMemory list(counterMain), temp_array(counterA), _
                (middle - counterA + 1) * Len(list(beginning))
        End If


        ' Copy any remaining items from the second half.
        If counterB <= ending Then
            CopyMemory list(counterMain), temp_array(counterB), _
                (ending - counterB + 1) * Len(list(beginning))
        End If


End Sub

 

[John_w]

Your code is sorting the list() array and attempting to keep the keyArray() array in the same order. The Do While loop correctly does this, however this part of the code must also do the same:

        ' Copy any remaining items from the first half.
        If counterA <= middle Then
            CopyMemory list(counterMain), temp_array(counterA), _
                (middle - counterA + 1) * Len(list(beginning))
        End If


        ' Copy any remaining items from the second half.
        If counterB <= ending Then
            CopyMemory list(counterMain), temp_array(counterB), _
                (ending - counterB + 1) * Len(list(beginning))
        End If

Change it to this:

    Dim n As Long

    ' Copy any remaining items from the first half.
    If counterA <= middle Then
        CopyMemory list(counterMain), temp_array(counterA), (middle - counterA + 1) * Len(list(beginning))
        n = 0
        For i = counterA To middle
            keyArray(counterMain + n) = temp_Key_Array(i)
            n = n + 1
        Next
    End If

    ' Copy any remaining items from the second half.
    If counterB <= ending Then
        CopyMemory list(counterMain), temp_array(counterB), (ending - counterB + 1) * Len(list(beginning))
        n = 0
        For i = counterB To ending
            keyArray(counterMain + n) = temp_Key_Array(i)
            n = n + 1
        Next
    End If

 

[brodaddy02]

Thank you John_w. I had to use the for loop for copying a string array. I could not figure out a simple way to use "CopyMemory" when I don't know the size of each string in the array. Thank you for your support.

 

[John_w]

I don't think you can use CopyMemory to copy an array of variable-length strings due to the way strings are held in memory.

One alternative for sorting an array of strings with CopyMemory is to provide a second array of indexes into the strings array. The indexes array starts in the order 1,2,3,4, etc., representing the original unsorted order of the strings array. Use CopyMemory to copy the indexes to or from the temp_array and wherever the Merge procedure accesses the strings array it must do it via the temp_array (i.e. the indexes) array, like this:

        If strings(temp_array(counterA)) <= strings(temp_array(counterB)) Then

Similarly, in the calling procedure you must access the strings array via the indexes array:

strings(indexes(i))

 

[brodaddy02]

Something still isn't quite right. Code below works on 380 array elements, but not on 27774 elements. Am I missing something?

Public Sub MergeSort(ByRef list() As Date, ByVal first_index As Long, ByVal last_index As Long)
    Dim middle As Long


    If (last_index > first_index) Then
        ' Recursively sort the two halves of the list.
        middle = (first_index + last_index) \ 2
        mMergeSort2.MergeSort list, first_index, middle
        mMergeSort2.MergeSort list, middle + 1, last_index


        ' Merge the results.
        mMergeSort2.Merge list, first_index, middle, last_index
    End If
End Sub


' Merge two sorted sublists.
Public Sub Merge(ByRef list() As Date, ByVal beginning As Long, ByVal middle As Long, ByVal ending As Long)
Dim temp_Array() As Date
Dim temp As Long
Dim counterA As Long
Dim counterB As Long
Dim counterMain As Long
Dim i As Long
Dim tempCounter As Long
Dim n As Long


    ' Copy the array into a temporary array.
    ReDim temp_Array(beginning To ending)
'    CopyMemory temp_Array(beginning), list(beginning), _
'        (ending - beginning + 1) * Len(list(beginning))
    For i = beginning To ending
        temp_Array(i) = list(i)
    Next i
        
       


    ' counterA and counterB mark the next item to save
    ' in the first and second halves of the list.
    counterA = beginning
    counterB = middle + 1


    ' counterMain is the index where we will put the
    ' next item in the merged list.
    counterMain = beginning
    Do While (counterA <= middle) And (counterB <= ending)
        ' Find the smaller of the two items at the front
        ' of the two sublists.
        If (temp_Array(counterA) <= temp_Array(counterB)) _
            Then
            ' The smaller value is in the first half.
            list(counterMain) = temp_Array(counterA)
            counterA = counterA + 1
        Else
            ' The smaller value is in the second half.
            list(counterMain) = temp_Array(counterB)
            counterB = counterB + 1
        End If
        counterMain = counterMain + 1
    Loop


    ' Copy any remaining items from the first half.
    If counterA <= middle Then
'        CopyMemory list(counterMain), temp_Array(counterA), _
'            (middle - counterA + 1) * Len(list(beginning))


        n = 0
        For i = counterA To middle
            list(counterMain + n) = temp_Array(i)
            n = n + 1
        Next
            


        
    End If


    ' Copy any remaining items from the second half.
    If counterB <= ending Then


        For i = counterB To ending
            list(counterMain + n) = temp_Array(i)
            n = n + 1
        Next


    End If
End Sub

 

[brodaddy02]

Code works on small arrays (380 elements), but doesn't work on 24473 elements. I can't seem to get it right. I do not know of a size limit when passing arrays.

Public Sub MergeSort(ByRef list() As Date, ByVal first_index As Long, ByVal last_index As Long)
    Dim middle As Long


    If (last_index > first_index) Then
        ' Recursively sort the two halves of the list.
        middle = (first_index + last_index) \ 2
        mMergeSort2.MergeSort list, first_index, middle
        mMergeSort2.MergeSort list, middle + 1, last_index


        ' Merge the results.
        mMergeSort2.Merge list, first_index, middle, last_index
    End If
End Sub


' Merge two sorted sublists.
Public Sub Merge(ByRef list() As Date, ByVal beginning As Long, ByVal middle As Long, ByVal ending As Long)
Dim temp_Array() As Date
Dim temp As Long
Dim counterA As Long
Dim counterB As Long
Dim counterMain As Long
Dim i As Long
Dim tempCounter As Long
Dim n As Long


    ' Copy the array into a temporary array.
    ReDim temp_Array(beginning To ending)
'    CopyMemory temp_Array(beginning), list(beginning), _
'        (ending - beginning + 1) * Len(list(beginning))
    For i = beginning To ending
        temp_Array(i) = list(i)
    Next i
        
       


    ' counterA and counterB mark the next item to save
    ' in the first and second halves of the list.
    counterA = beginning
    counterB = middle + 1


    ' counterMain is the index where we will put the
    ' next item in the merged list.
    counterMain = beginning
    Do While (counterA <= middle) And (counterB <= ending)
        ' Find the smaller of the two items at the front
        ' of the two sublists.
        If (temp_Array(counterA) <= temp_Array(counterB)) _
            Then
            ' The smaller value is in the first half.
            list(counterMain) = temp_Array(counterA)
            counterA = counterA + 1
        Else
            ' The smaller value is in the second half.
            list(counterMain) = temp_Array(counterB)
            counterB = counterB + 1
        End If
        counterMain = counterMain + 1
    Loop


    ' Copy any remaining items from the first half.
    If counterA <= middle Then
'        CopyMemory list(counterMain), temp_Array(counterA), _
'            (middle - counterA + 1) * Len(list(beginning))


        n = 0
        For i = counterA To middle
            list(counterMain + n) = temp_Array(i)
            n = n + 1
        Next
            


        
    End If


    ' Copy any remaining items from the second half.
    If counterB <= ending Then
    
        n = 0
        For i = counterB To ending
            list(counterMain + n) = temp_Array(i)
            n = n + 1
        Next


    End If
End Sub

 

[John_w]

Your code works for me - I tested it on an array of 30,000 dates. But you've changed your code: it now only sorts an array of dates. You can use CopyMemory (instead of the For Next loops) if it is sorting data types which have a fixed size (e.g. Date, Long, Integer, etc.) and the sort will be faster than using For Next loops.

 

[brodaddy02]

John_w,

It works for me as well when I create the dates manually. I am passing a the address of a private array variable to another module. I wonder if that is messing up the algorithm.

 

[John_w]

Can you post your code which calls MergeSort and demonstrates the problem?

 

[brodaddy02]

John_w,

I appreciate the time. If you can help, it will be greatly appreciated. I think that I only gave the code to test. I am trying to figure out how to get you the raw data .csv file.

'This is the main module 
Option Explicit

'Private global variables in module
Private p_MasterDict As Dictionary  
Private p_SortDict As Dictionary
Private p_SortedArray() As String


Public Sub Main()
    Application.ScreenUpdating = False
    Set p_MasterDict = New Dictionary
    Set p_SortDict = New Dictionary


    Dim fso As FileSystemObject: Set fso = New FileSystemObject
    Dim txtFile As TextStream
    Dim tempICN As cICN
    Dim splitArray() As String
    Dim i As Long


    Set txtFile = fso.OpenTextFile("RawData", ForReading, False)
        With txtFile        Do Until .AtEndOfStream
            splitArray = Split(.ReadLine, ",")
            p_SortDict.Add Trim(splitArray(0)), CDate(splitArray(1))
        Loop
    End With

    'sort dictionary
    Dim ItemArray() As Variant: ItemArray = p_SortDict.Items
    Dim NewItemArray() As Date: ReDim NewItemArray(0 To UBound(ItemArray, 1)) As Date

    'I couldn't get it to work with variant datatypes, so I tried to create a string and date array to get that to work.
    Dim KeyArray() As Variant: KeyArray = p_SortDict.Keys
    ReDim p_SortedArray(0 To UBound(ItemArray, 1))

    For i = 0 To UBound(ItemArray)
        NewItemArray(i) = CDate(ItemArray(i))
        p_SortedArray(i) = CStr(KeyArray(i))
    Next i


    Erase ItemArray
    Erase KeyArray




    Call mMergeSort.MergeSort(NewItemArray, LBound(NewItemArray, 1), UBound(NewItemArray, 1))
    'I check NewItemArray in watch window, and it doesn't work
    Application.ScreenUpdating = True
End Sub

' This is the Mergesort in a different module called "mMergeSort"

Public Sub MergeSort(ByRef list() As Date, ByVal first_index As Long, ByVal last_index As Long)
    Dim middle As Long


    If (last_index > first_index) Then
        ' Recursively sort the two halves of the list.
        middle = (first_index + last_index) \ 2
        mMergeSort.MergeSort list, first_index, middle
        mMergeSort.MergeSort list, middle + 1, last_index


        ' Merge the results.
        mMergeSort.Merge list, first_index, middle, last_index
    End If
End Sub


' Merge two sorted sublists.
Public Sub Merge(ByRef list() As Date, ByVal beginning As Long, ByVal middle As Long, ByVal ending As Long)
Dim temp_Array() As Date
Dim temp As Long
Dim counterA As Long
Dim counterB As Long
Dim counterMain As Long
Dim i As Long
Dim tempCounter As Long
Dim n As Long


    ' Copy the array into a temporary array.
    ReDim temp_Array(beginning To ending)
'    CopyMemory temp_Array(beginning), list(beginning), _
'        (ending - beginning + 1) * Len(list(beginning))
    For i = beginning To ending
        temp_Array(i) = list(i)
    Next i
        
       


    ' counterA and counterB mark the next item to save
    ' in the first and second halves of the list.
    counterA = beginning
    counterB = middle + 1


    ' counterMain is the index where we will put the
    ' next item in the merged list.
    counterMain = beginning
    Do While (counterA <= middle) And (counterB <= ending)
        ' Find the smaller of the two items at the front
        ' of the two sublists.
        If (temp_Array(counterA) <= temp_Array(counterB)) _
            Then
            ' The smaller value is in the first half.
            list(counterMain) = temp_Array(counterA)
            counterA = counterA + 1
        Else
            ' The smaller value is in the second half.
            list(counterMain) = temp_Array(counterB)
            counterB = counterB + 1
        End If
        counterMain = counterMain + 1
    Loop


    ' Copy any remaining items from the first half.
    If counterA <= middle Then
'        CopyMemory list(counterMain), temp_Array(counterA), _
'            (middle - counterA + 1) * Len(list(beginning))


        n = 0
        For i = counterA To middle
            list(counterMain + n) = temp_Array(i)
            n = n + 1
        Next


    End If


    ' Copy any remaining items from the second half.
    If counterB <= ending Then
    
        n = 0
        For i = counterB To ending
            list(counterMain + n) = temp_Array(i)
            n = n + 1
        Next


    End If
End Sub