Excel VBA收集合并sorting
我正试图直接在集合上实现MergeSort。 这是从用于C ++的伪代码移植过来的。 但是，MergeSort方法正在返回没有数据。 我的testing用例正在使用{1,2,3,2,4}的input集合，并正在返回Count = 0的集合。问题出现在removeDupl = True和removeDupl = False。 代码下面是一些debugging日志的结果，这些日志似乎显示了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
@xidgel是正确的：它适用于string。 “在错误恢复下一个”语句隐藏2错误：
-
错误457：此键已与此集合的一个元素（预期）
-
错误：13：types不匹配
要使用数字将它们转换为string（向它们附加一个空string（“”））
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
。
testing：
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 '------------------------------------------------------------------------------------------
在2011年撰写了关于这个确切主题的博客文章 …我的代码可以自由使用。 我的代码的一个特别有用的function是：它可以用于通过命名属性sorting对象集合。
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). 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 eg 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. eg 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