Excel VBA 集合合并排序

Question

我正在尝试直接在集合上实现合并排序。这是从用于 C++ 的伪代码移植的。但是，MergeSort 方法不返回任何数据。我的测试用例使用 {1, 2, 2, 3, 3, 4} 的输入集合，并返回一个 Count = 0 的集合。问题是在removeDupl = True 和removeDupl = False 时发生的。代码下方是一些调试日志的结果，这些日志似乎显示合并排序在列表的 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

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