Excel VBA Collection Merge Сортировка

Question

Я пытаюсь реализовать MergeSort непосредственно в коллекции. Это было перенесено из psuedo-кода, предназначенного для C++. Однако метод MergeSort не возвращает данных. В моем тестовом примере используется входная коллекция {1, 2, 2, 3, 3, 4} и возвращает коллекцию с Count = 0. Проблема заключается в том, что с помощью removeDupl = True и removeDupl = False. Ниже кода представлены результаты некоторых журналов отладки, которые, как представляется, показывают, что mergesort частично выполняется через 3 члена списка. Почему метод не возвращает значения?

Private Function mergeSort(col As Collection, Optional removeDupl = True) As Collection 
' 
'Execute a Merge sort 
'removeDupl = True yields a sorted collection with unique values 
'removeDupl = False yields a sorted collection with non-unique values 
' 

If col.Count = 1 Then 

    Set mergeSort = col 

Else 
    Dim tempCol1 As Collection 
    Dim tempCol2 As Collection 
    Set tempCol1 = New Collection 
    Set tempCol2 = New Collection 

    For i = 1 To col.Count/2 

     tempCol1.Add col.Item(i) 
     tempCol2.Add col.Item(i + (col.Count/2)) 

    Next i 

    Set tempCol1 = mergeSort(tempCol1) 
    Set tempCol2 = mergeSort(tempCol2) 

    Set mergeSort = merge(tempCol1, tempCol2, removeDupl) 
End If 
End Function 

Private Function merge(col1 As Collection, col2 As Collection, ByVal removeDupl As Boolean) As Collection 

If removeDupl = True Then 
    On Error Resume Next 
End If 

Dim tempCol As Collection 
Set tempCol = New Collection 
Do While col1.Count <> 0 And col2.Count <> 0 

    If col1.Item(1) > col2.Item(1) Then 

     If removeDupl = True Then 
      tempCol.Add col2.Item(1), col2.Item(1) 
     Else 
      tempCol.Add col2.Item(1) 
     End If 
     col2.Remove (1) 

    Else 

     If removeDupl = True Then 
      tempCol.Add col1.Item(1), col1.Item(1) 
     Else 
      tempCol.Add col1.Item(1) 
     End If 
     col1.Remove (1) 

    End If 

    Loop 


    Do While col1.Count <> 0 

    If removeDupl = True Then 
     tempCol.Add col1.Item(1), col1.Item(1) 
    Else 
     tempCol.Add col1.Item(1) 
    End If 
    col1.Remove (1) 

    Loop 

    Do While col2.Count <> 0 

    If removeDupl = True Then 
     tempCol.Add col2.Item(1), col2.Item(1) 
    Else 
     tempCol.Add col2.Item(1) 
    End If 
    col2.Remove (1) 

    Loop 

On Error GoTo 0 
Set merge = tempCol 
End Function 

---

mergeSort Called 

--col.Count = 6 
----col.Item(1 + col.Count/2) = 2 
----col.Item(1) = 1 
----col.Item(2 + col.Count/2) = 3 
----col.Item(2) = 2 
----col.Item(3 + col.Count/2) = 4 
----col.Item(3) = 3 

mergeSort Called 

--col.Count = 3 
----col.Item(1 + col.Count/2) = 2 
----col.Item(1) = 1 

mergeSort Called 

--col.Count = 1 

mergeSort Called 

--col.Count = 1 

merge called 

--col1.Count = 1 
--col2.Count = 1 

1 compared to 2 

----1 Added 
----2 Added 

mergeSort Called 

--col.Count = 3 
----col.Item(1 + col.Count/2) = 3 
----col.Item(1) = 2 

mergeSort Called 

--col.Count = 1 

mergeSort Called 

--col.Count = 1 

merge called 

--col1.Count = 1 
--col2.Count = 1 

2 compared to 3 

----2 Added 
----3 Added 

merge called 

--col1.Count = 0 
--col2.Count = 0 

Answer 1

@xidgel правильно: он работает со строками. "On Error Resume Next" заявление пряталось 2 ошибки:

• Ошибка 457: Этот ключ уже связан с элементом этой коллекции (ожидается)

• Ошибки: 13: Несоответствие типов

чтобы использовать номера конвертировать их в строки (добавление пустой строки к ним (""))

Option Explicit 

Private Function mergeSort(c As Collection, Optional uniq = True) As Collection 

    Dim i As Long, xMax As Long, tmp1 As Collection, tmp2 As Collection, xOdd As Boolean 

    Set tmp1 = New Collection 
    Set tmp2 = New Collection 

    If c.Count = 1 Then 
     Set mergeSort = c 
    Else 

     xMax = c.Count 
     xOdd = (c.Count Mod 2 = 0) 
     xMax = (xMax/2) + 0.1  ' 3 \ 2 = 1; 3/2 = 2; 0.1 to round up 2.5 to 3 

     For i = 1 To xMax 
      tmp1.Add c.Item(i) & "" 'force numbers to string 
      If (i < xMax) Or (i = xMax And xOdd) Then tmp2.Add c.Item(i + xMax) & "" 
     Next i 

     Set tmp1 = mergeSort(tmp1, uniq) 
     Set tmp2 = mergeSort(tmp2, uniq) 

     Set mergeSort = merge(tmp1, tmp2, uniq) 

    End If 
End Function 

---

Private Function merge(c1 As Collection, c2 As Collection, _ 
         Optional ByVal uniq As Boolean = True) As Collection 

    Dim tmp As Collection 
    Set tmp = New Collection 

    If uniq = True Then On Error Resume Next 'hide duplicate errors 

    Do While c1.Count <> 0 And c2.Count <> 0 
     If c1.Item(1) > c2.Item(1) Then 
      If uniq Then tmp.Add c2.Item(1), c2.Item(1) Else tmp.Add c2.Item(1) 
      c2.Remove 1 
     Else 
      If uniq Then tmp.Add c1.Item(1), c1.Item(1) Else tmp.Add c1.Item(1) 
      c1.Remove 1 
     End If 
    Loop 

    Do While c1.Count <> 0 
     If uniq Then tmp.Add c1.Item(1), c1.Item(1) Else tmp.Add c1.Item(1) 
     c1.Remove 1 
    Loop 
    Do While c2.Count <> 0 
     If uniq Then tmp.Add c2.Item(1), c2.Item(1) Else tmp.Add c2.Item(1) 
     c2.Remove 1 
    Loop 
    On Error GoTo 0 

    Set merge = tmp 

End Function 

.

Тесты:

Public Sub testInts() 
    Dim tmp As Collection: Set tmp = New Collection 

    tmp.Add 3: tmp.Add 1: tmp.Add 4 
    'if next line (2) is commented out:  if dupes: "1,3,4,4" if uniques: "1,3,4" 
    tmp.Add 2     'else:  if dupes: "1,2,3,4,4 if uniques: "1,2,3,4" 
    tmp.Add 4 
    Set tmp = mergeSort(tmp, False) 
End Sub 

Public Sub testStrings() 
    Dim tmp As Collection: Set tmp = New Collection 

    tmp.Add "C": tmp.Add "A": tmp.Add "D" 
    'if next line ("B") is commented out: if dupes: "A,C,D,D" if uniques: "A,C,D" 
    'tmp.Add "B"   'else:    if dupes: "A,B,C,D,D" if uniques: "A,B,C,D" 
    tmp.Add "D" 
    Set tmp = mergeSort(tmp, False) 
End Sub 

'------------------------------------------------------------------------------------------ 

Answer 2

писал a blog article on this exact subject, в 2011 году ... Мой код может свободно использовать. Одна из особенно полезных особенностей моего кода: его можно использовать для сортировки коллекций объектов с помощью именованного свойства.

Attribute VB_Name = "Collections" 
 
Option Compare Database 
 
Option Explicit 
 
' Note that STRING INDEXED ARRAYS are called "Dictionary". Available from Windows Scripting Runtime. 
 
' SORTING ARRAYS OF User Defined Types: http://www.dailydoseofexcel.com/archives/2006/02/23/sorting-arrays-of-user-defined-types/ 
 
' For HeapSort: http://www.source-code.biz/snippets/vbasic/6.htm 
 

 
'*********************************************************************************************** 
 
'THE MERGESORT ALGORITHM FOR SORTING IN O(n.log(n)) TIME - Applied to VBA COLLECTION objects... 
 
'*********************************************************************************************** 
 
' © 2005-2011 Matthew Slyman. Copying, modification and distribution in software is permitted. 
 
' Attribution of work to author is required, and unauthorised redistribution is not permitted. 
 
' Copyright notice must remain intact. 
 
Public Function MergeSortCollection(ByRef CollectionToSort As Collection, Optional ByVal OrderByProperty As String, Optional ByVal OrderByType As String, Optional ByVal InDescendingOrder As Boolean = False, Optional DISTINCT As Boolean = False) As Collection ' Optional CompareMode As VbCompareMethod = vbTextCompare ' - potentially useful for Strings ''' Optional identify_by_obj_guid As Boolean = True ' - alternative being to identify by Parameters. See below under "=Potentially fixable weaknesses of this routine:===" 
 
' >>> What about ORDERing by Array or Collection of properties? 
 
On Error GoTo Failed 
 
    If CollectionToSort.Count > 1 Then 
 
     If LenB(OrderByType) = 0 Then ' If sorting by a Variant, the OrderByType parameter enables the programmer to specify how to sort it (numerical or string based sorting). Otherwise, the VBA code below can automatically detect the data type of the sorting/comparison variable. 
 
      Dim testVar As Variant ' <<< Should perhaps be using the IsObject function... Investigate whether this would result in a more reliable SortByMerge function. Think about the potential use of default Value. 
 
      If LenB(OrderByProperty) = 0 Then 
 
       testVar = CollectionToSort(1) 
 
      Else 
 
       testVar = CollectionToSort(1).Properties(OrderByProperty) 
 
      End If 
 
      OrderByType = TypeName(testVar) 
 
     End If 
 
     ' >>> Need to think about USER-DEFINED TYPES! And how to use Properties() in them! Remember that user-defined types are NOT Objects... << Actually, Collection objects themselves do not appear to handle UDTs (user-defined types) gracefully at all - so it is very unlikely that someone would be using this routine on a Collection of UDT-variables at all. 
 
     Select Case OrderByType ' VarType function results: vbNull; vbInteger; vbLong; vbSingle; vbDouble; vbCurrency; vbDate; vbString; vbObject; vbError; vbBoolean; vbVariant; vbDataObject; vbDecimal; vbByte; vbUserDefinedType; vbArray 
 
      Case "Single", "Double", "String", "Integer", "Long", "Byte", "Currency", "Decimal", "Date": ' Boolean? 
 
      Case Else: 
 
       Err.Raise number:=vbObjectError + 1, Source:="AAA.Collections.MergeSortCollection", Description:="OrderBy Type not recognized. Use Single, Double, String, Integer, Long, Byte, Currency, Decimal or Date" 
 
     End Select 
 
     ' <<< Might push the stuff above this line into a separate initialization function, for efficiency reasons. 
 
    End If 
 
    Dim SortedCollection As New Collection 
 
    Select Case CollectionToSort.Count 
 
     Case 0, 1: 
 
      Set MergeSortCollection = CollectionToSort 
 
     Case Else: 
 
      Dim Size1 As Long, Size2 As Long, CollectionToSortSize As Long, counter As Long 
 
      Dim Collection1 As New Collection, Collection2 As New Collection 
 
      CollectionToSortSize = CollectionToSort.Count 
 
      Size1 = Round(CollectionToSortSize/2, 0) 
 
      Size2 = CollectionToSortSize - Size1 
 
      For counter = 1 To CollectionToSort.Count 
 
       If counter <= Size1 Then Collection1.Add CollectionToSort(counter) Else Collection2.Add CollectionToSort(counter) 
 
      Next counter 
 
      Set MergeSortCollection = MergeInOrder(MergeSortCollection(Collection1, OrderByProperty, OrderByType, InDescendingOrder, DISTINCT), MergeSortCollection(Collection2, OrderByProperty, OrderByType, InDescendingOrder, DISTINCT), OrderByProperty, OrderByType, InDescendingOrder, DISTINCT) 
 
    End Select 
 
    Exit Function 
 
Failed: 
 
    Debug.Print "#ERROR# " & Err.number & " : " & Err.Source & ".Collections.MergeSortCollection " & vbCrLf & " - " & Err.Description 
 
    Err.Clear 
 
End Function 
 
Private Function MergeInOrder(ByRef Collection1 As Collection, ByRef Collection2 As Collection, Optional OrderByProperty As String = "", Optional OrderByType As String = "String", Optional ByVal InDescendingOrder As Boolean = False, Optional DISTINCT As Boolean = False) As Collection 
 
' The other half of the MERGESORT algorithm, for COLLECTIONS... An auxiliary function for the recursive MergeSort function... The first function splits the Collections successively into halves, and then this function merges the halves in order, successively, until the resulting sorted Collection is returned. 
 
' >> NEED to use . dot delimited Properties for multiple levels of objects... Could also replace with Collection. Automatically determine the types of those properties. Sort accordingly. 
 
' >>> Yet to rigorously test sorting stability (to see whether function preserves original ordering as far as possible).&nbsp; Appears to do so... Just want to make sure... 
 
' >>> Yet to rigorously test worst-case space complexity. Appears to be O(n) but just want to make sure it is in practice... 
 
    Dim SortedCollection As New Collection 
 
    Dim Counter1 As Long, Counter2 As Long 
 
    Counter1 = 1 
 
    Counter2 = 1 
 
    Dim ComparisonFlag As Boolean 
 
    Do While Counter1 <= Collection1.Count And Counter2 <= Collection2.Count 
 
     Dim ComparisonVariable1 As Variant, ComparisonVariable2 As Variant 
 
     If DISTINCT Then 
 
      Dim IdenticalNodes As Boolean ' Not necessary to compare e.g. Collection1(1) with Collection1(2) because Collection1 itself will already have been split and merged, and recursively tested for identical elements via this MergeInOrder function. 
 
      If Not (LenB(OrderByProperty) <> 0) Then ' <<< Should perhaps be using the IsObject function... Investigate whether this would result in a more reliable SortByMerge function. 
 
       IdenticalNodes = (Collection1(Counter1) = Collection2(Counter2)) 
 
      Else 
 
       IdenticalNodes = (Collection1(Counter1) Is Collection2(Counter2)) 
 
      End If 
 
      If IdenticalNodes Then 
 
       SortedCollection.Add Collection1(Counter1) 
 
       Counter1 = Counter1 + 1 ' Already inserted into SortedCollection. 
 
       Counter2 = Counter2 + 1 ' Pass over the duplicate. 
 
       GoTo SkipComparison 
 
      End If 
 
     End If 
 
     If Not (LenB(OrderByProperty) <> 0) Then 
 
      ComparisonVariable1 = Collection1(Counter1) 
 
      ComparisonVariable2 = Collection2(Counter2) 
 
     Else 
 
      ComparisonVariable1 = Collection1(Counter1).Properties(OrderByProperty) 
 
      ComparisonVariable2 = Collection2(Counter2).Properties(OrderByProperty) 
 
     End If 
 
     Select Case OrderByType ' Using a text-based parameter, rather than automatically detecting type, 
 
      Case "Boolean": ComparisonFlag = CBool(ComparisonVariable1) < CBool(ComparisonVariable2) ' << WARNING: Numeric representation of "True" constant depends on system implementation. e.g. VBA (INT -1) differs from SQL Server (BIT 1) in this respect. Is TRUE<FALSE or is FALSE>TRUE? 
 
      Case "Single": ComparisonFlag = CSng(ComparisonVariable1) < CSng(ComparisonVariable2) 
 
      Case "Double": ComparisonFlag = CDbl(ComparisonVariable1) < CDbl(ComparisonVariable2) 
 
      Case "String": ComparisonFlag = (-1 = Strings.StrComp(CStr(ComparisonVariable1), CStr(ComparisonVariable2), vbTextCompare)) 
 
      Case "Integer", "Long", "Byte": ComparisonFlag = CLng(ComparisonVariable1) < CLng(ComparisonVariable2) 
 
      Case "Currency": ComparisonFlag = CCur(ComparisonVariable1) < CCur(ComparisonVariable2) ' What about comparison of dissimilar currencies in heterogeneous forex environment? 
 
      Case "Decimal": ComparisonFlag = CDec(ComparisonVariable1) < CDec(ComparisonVariable2) 
 
      Case "Date": ComparisonFlag = CDate(ComparisonVariable1) < CDate(ComparisonVariable2) 
 
     End Select 
 
     If InDescendingOrder Then ComparisonFlag = Not ComparisonFlag 
 
     If ComparisonFlag Then 
 
      SortedCollection.Add Collection1(Counter1) 
 
      Counter1 = Counter1 + 1 
 
     Else 
 
      SortedCollection.Add Collection2(Counter2) 
 
      Counter2 = Counter2 + 1 
 
     End If 
 
SkipComparison: 
 
    Loop 
 
    Do While Counter1 <= Collection1.Count 
 
     SortedCollection.Add Collection1(Counter1) 
 
     Counter1 = Counter1 + 1 
 
    Loop 
 
    Do While Counter2 <= Collection2.Count 
 
     SortedCollection.Add Collection2(Counter2) 
 
     Counter2 = Counter2 + 1 
 
    Loop 
 
    Set Collection1 = Nothing 
 
    Set Collection2 = Nothing 
 
    Set MergeInOrder = SortedCollection 
 
' Set SortedCollection = Nothing ' Would this not muck up the results of the function? Remember, MergeInOrder is still set by Object Ref to SortedCollection. They are essentially the same object... 
 
End Function 
 
' END OF MERGESORT FOR COLLECTIONS