Excel VBA集合合并排序_Excel_Sorting_Collections_Mergesort_Vba

Excel VBA集合合并排序

excel sorting collections vba

Excel VBA集合合并排序,excel,sorting,collections,mergesort,vba,Excel,Sorting,Collections,Mergesort,Vba,我试图直接在集合上实现MergeSort。这是从pSeEDO代码移植到C++的。但是，MergeSort方法不返回任何数据。我的测试用例使用一个输入集合{1，2，2，3，3，4}，并返回一个计数为0的集合。removeDupl=True和removeDupl=False时出现问题。代码下面是一些调试日志的结果，这些日志似乎显示了在列表的3个成员之间部分执行的mergesort。为什么该方法不返回任何值 Private Function mergeSort(col As Collection, O

我试图直接在集合上实现MergeSort。这是从pSeEDO代码移植到C++的。但是，MergeSort方法不返回任何数据。我的测试用例使用一个输入集合{1，2，2，3，3，4}，并返回一个计数为0的集合。removeDupl=True和removeDupl=False时出现问题。代码下面是一些调试日志的结果，这些日志似乎显示了在列表的3个成员之间部分执行的mergesort。为什么该方法不返回任何值

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

@xidgel是正确的：它与字符串一起工作。“On Error Resume Next”语句隐藏了2个错误：

错误457:此键已与此集合的元素关联（预期）
错误：13:类型不匹配

要使用数字，请将其转换为字符串（在数字后面附加一个空字符串（“”））

2011年写的…我的代码可以免费使用。我的代码的一个特别有用的特性是：它可以用于按命名属性对对象集合进行排序

属性VB\u Name=“集合”
选项比较数据库
选项显式
'注意，字符串索引数组称为“字典”。可从Windows脚本运行时获得。
'对用户定义类型的数组进行排序：http://www.dailydoseofexcel.com/archives/2006/02/23/sorting-arrays-of-user-defined-types/
'对于HeapSort：http://www.source-code.biz/snippets/vbasic/6.htm
'***********************************************************************************************
'用于按O（n.log（n））时间排序的MERGESORT算法-应用于VBA集合对象。。。
'***********************************************************************************************
©2005-2011马修·斯莱曼。允许在软件中复制、修改和分发。
“作品必须归作者所有，未经授权不得转载。
“版权声明必须保持完整。
公共函数MergeSortCollection（ByRef CollectionToSort作为集合，可选ByVal OrderByProperty作为字符串，可选ByVal OrderByType作为字符串，可选ByVal InDescendingOrder作为Boolean=False，可选DISTINCT作为Boolean=False）As集合“可选CompareMode As VbCompareMethod=vbTextCompare”-可能对字符串“”有用“可选Identification_by_obj_guid As Boolean=True”-也可以通过参数进行标识。请参见下面的“=此例程的潜在可修复弱点：=”
'>>>按数组或属性集合排序如何？
在发生错误时，转到失败
如果CollectionToSort.Count>1，则
如果LenB（OrderByType）=0，则“如果按变量排序，则OrderByType参数允许程序员指定如何对其排序（数字或基于字符串的排序）。否则，下面的VBA代码可以自动检测排序/比较变量的数据类型。
Dim testVar作为变体'>>尚未严格测试最坏情况下的空间复杂性。看起来是O（n），但只是想确保它在实践中。。。
Dim SortedCollection作为新集合
调暗计数器1的长度与计数器2的长度相同
计数器1=1
计数器2=1
Dim ComparisonFlag作为布尔值
Do While Counter1 IIRC.Item（arg），.Remove（arg）将接受索引或键作为参数。看起来您正在测试一组整数。VB可能无法判断您指的是索引还是键，因此请尝试对字符串集合进行测试。这将返回我在日志中看到正在处理的部分完成的集合，谢谢！我怎样才能使整型集合适用于此？虽然此链接可以回答此问题，但最好在此处包含答案的基本部分，并提供链接供参考。如果链接页面发生更改，仅链接的答案可能无效。-@埃利亚萨：谢谢。已更新以包含源代码。我通常很小心地维护我知道人们用来解决问题的链接，但是“安全带和支架”-以防出现任何错误和代码丢失！
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

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

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