【旧投稿】VBAで高速に動くソート可能な動的リスト作った(Winならユニーク化も!)

この投稿は以前のものです

大幅にクラスの内容を刷新した上で書き直したため、こちらをご覧ください。
https://qiita.com/es2/private/04120886c089608d207e

概要

VBAの動的配列にあたるCollectionは要素の自乗倍重くなりArrayListは.netの新しいバージョンだと使えない
拾ってきたListは配列を毎回Redim(遅い)し使いたいメソッドもなかったためまともな?Listを作ってみました!
※このListはStringやLongなどプリミティブな型にしか対応しておりません。参照型はまた今度

2020/12/30追記:StringBuilder的な高速結合とプラス要素間にデリミタ文字列を付与する機能追加

クラスだけ欲しい方は下の
ここから下をコピーして Listという名前のクラスモジュールに入れてくれい!!からコピペしてね

例えばこういうことが出来ます!!

Dim List as List:set List as New List
List.Add(1) '要素を追加します
call List.AddRange(Range("A1:A1048576").Value) '複数要素を追加します。
List.OrderBy'リストの内容をソートします
arr= List.ToArray '配列を返します。つまり for each elm in List.Toarrayなどとかけます。
set newList = List.DistinctToNewList '内容重複がない新しいリストを返します(Win限定追加機能)
set newList2 = List.PopRange(1,10)'1-10の要素を新しいリストで返し元のリストから消します
str = List.ToBuildStringWithDelimiter(",")'要素をカンマで区切って高速結合(100万個で&結合の1000倍超速)

出来ること

基本

Add:値を追加します。これは値の数が増えれば増えるほどCollectionより早いです。
AddRange:イテレート可能な(for eachができる)値を追加していきます。Listは専用メソッド有
ToArray:配列として返します。要素数はデータ数に切り詰められます。0スタートです。
OrderBy/SortByAscending:値を昇順ソート。降順はSortByDescending/OrderByDescending
Count:格納されている個数を取得します。indexの最大値はCount -1よ?

準基本

ConcatList:AddRangeのリスト用メソッドです。
First:最初の要素を返します。
Last:最後の要素を返します。
GetValueOfIndex:配列に対する(n)と同じです。
Remove:n番目の要素を削除して詰めます(あまりはやくない)
RemoveAt:引数に一致する値(=で一致するもの)を削除します
RemoveAll:引数に一致するもの(=で一致するもの)を全て削除します。この名前でいいのか?
Pop:n番目の要素を取得して、リストからその値を消して前に詰めます
PopAt:引数に一致する値(=で一致するもの)を取得してリストからその値を消して前に詰めます
Clone:リストを複製して返します。
Reverse:格納されている値を反転します。
Randamize:値をシャッフルします。精度はいまいちだと思います

応用 (Range系のメソッドで範囲外を指定した場合はコメント参照)

TakeToNewList:前方からn個要素を取得して新しいリストを返します。
SkipToNewList:指定数をスキップしてそれ以降を抜き出します。
GetRange指定範囲の値を別のリストとして返します
RemoveRange:指定範囲を削除して前に詰めます(要検証)
PopRange:指定範囲を取得して、リストからその値を消して前に詰めます(要検証)
StringContains:値を文字列で検索してBoolを返します。
ToBuildString:要素を全て結合した文字列を返します(100万個結合で&結合の1000倍以上早かった)
ToBuildStringWithDelimiter:要素間に引数の文字列を追加して結合した文字列を返します。

Math系のメソッド

※数値が入っていること前提です。下の方にあるので必要なら追加してください。
WorkSheetFunctionはセルに入っている値以外だと個数制限がある。
Sum,Average,Median,Max,Min,StDevP

Windowsでないと動かないと思われる機能

※下の方にあるので必要なら追加してください。
DistinctToNewList:ユニーク(内容で重複しているものがない状態)の新しいリストを返します
StringContains_RegExp:値を正規表現で検索してBoolを返します。
ModeSingle:最頻値を1つ取得します。数値が入っていること前提です
ModeMulti:最頻値を配列で取得します。数値が入っていること前提です

バグなどはコメントで教えてくれると嬉しいです(直るとはいっていない)
参照型はWhere,Selectぐらいは作りたいなと思って途中で放置中です。メンドクサイ

ここから下をコピーして Listという名前のクラスモジュールに入れてくれい!!

Option Base 0 'クラス内の処理で1の方が都合がいいが、ToArrayした場合の返り値などにも影響を及ぼすので・・・

Private myArr As Variant 'ここに値が入ります(cloneの仕様のためローカル変数全部普通に触れます(あぶない))
Private myCount As Long '配列の要素数です。
Private myCapacity As Long '配列の最大サイズです。

Property Get arr() As Variant: arr = myArr: End Property
Property Let arr(arg): myArr = arg: End Property

Property Get Count() As Long: Count = myCount: End Property
Property Let Count(arg As Long): myCount = arg: End Property

Property Get Capacity() As Long: Capacity = myCapacity: End Property
Property Let Capacity(arg As Long): myCapacity = arg: End Property

'コンストラクタです。クラスの初期化を行います。 配列の初期サイズ決めたかったのですが、仕様上引数渡せないみたいです()
Private Sub Class_Initialize()
    myCapacity = 0
    ReDim myArr(myCapacity)
End Sub

'デストラクタです、メモリを開放します。
Private Sub Class_Terminate()
    Set myArr = Nothing
    VBA.DoEvents
End Sub

'クラスを初期化します。
Public Function Clear()
    myCount = 0
    Call Class_Initialize
End Function

'値をリストに追加します。
'動作速度とメモリの観点から、格納アイテム数が配列のキャパシティを超えた場合のみReDim Preserveを行いキャパシティを倍にします。
Public Sub Add(val)
   
    If myCount > myCapacity Then
        myCapacity = (myCapacity + 1) * 2 - 1
        ReDim Preserve myArr(myCapacity)
    End If
   
    myArr(myCount) = val
    myCount = myCount + 1
   
End Sub

'配列若しくは、イテレート可能なオブジェクトを追加します。call を先頭に付けないと動かないぽいです。ハマりました。
Public Sub AddRange(args As Variant)

    For Each arg In args
        Me.Add (arg)
    Next

End Sub

'2つのリストを結合します。引数に入れたほうがあとに来ます。
'シグネチャで型を指定すると、使用側で明示的にListの型を指定していない場合受けられないためVariantです。
'使用側でcallを付ける必要があります。
Public Sub ConcatList(argList As Variant)
   
    If argList.Count = 0 Then Exit Sub
    For Each elm In argList.ToArray
        Me.Add (elm)
    Next

End Sub

'最初の要素を取得します。
Public Function First(): First = IIf(myCount = 0, Empty, myArr(0)): End Function

'最後の要素を取得します。
Public Function Last(): Last = IIf(myCount = 0, Empty, myArr(myCount - 1)): End Function

 'インデックス値に対応する値を取得します。配列の[n]と同じです。
 Public Function GetValueOfIndex(index As Long)
 
    If index > myCount Then
        GetValueOfIndex = Empty
    Else
        GetValueOfIndex = myArr(index)
    End If
   
End Function

'特定の範囲を抜き出して新しいリストとして返します。(minIndex<=抜き出すもの<=maxIndex)
'Minが不当に小さい、Maxが不当に大きい場合、最小インデックス、最大インデックスまでの要素を対象とします。
Public Function GetRange(minIndex As Long, maxIndex As Long) As List
   
    minIndex = IIf(minIndex < LBound(myArr), LBound(myArr), minIndex)
    maxIndex = IIf(maxIndex > myCount - 1, myCount - 1, maxIndex)
   
    If minIndex > maxIndex Then
        Set GetRange = New List
        Exit Function
    End If
   
    Dim newlist As List: Set newlist = New List
   
    For i = minIndex To maxIndex
        newlist.Add (myArr(i))
    Next i
   
    Set GetRange = newlist
   
End Function

'indexに対応する要素を削除してデータを前に詰めます。効率はなんとなく悪そうかなと
Public Sub Remove(index As Long)
   
    If myCount = 0 Then Exit Sub
    If index < LBound(myArr) Or UBound(myArr) < index Then Exit Sub
   
    For i = index To myCount - 1
        myArr(i) = myArr(i + 1)
    Next i
       
    myCount = myCount - 1
    myArr(myCount) = Empty

End Sub

'一番最初に引数の数値に引っかかったものを削除してデータを前に詰める
Public Sub RemoveAt(val)
   
    If myCount = 0 Then Exit Sub
   
    Dim i As Long
    For i = LBound(myArr) To myCount - 1
        If myArr(i) = val Then
            Call Remove(i)
            Exit Sub
        End If
    Next i

End Sub

'引数の数値に一致するものを全て削除してデータを前に詰める というかどうせ全部走査して前に詰めるならリスト作り直す。
Public Sub RemoveAll(val)

    Dim newlist As List: Set newlist = New List
   
    Dim buf
    For i = LBound(myArr) To myCount - 1
        buf = myArr(i)
        If buf <> val Then
            newlist.Add (buf)
        End If
    Next i
  
    myArr = newlist.arr
    myCount = newlist.Count
    myCapacity = newlist.Capacity
   
End Sub

'動くけどあやしい・・・
'特定の範囲を削除して詰めます。(minIndex<=ここ消える<=maxIndex)
'Minが不当に小さい、Maxが不当に大きい場合、最小インデックス、最大インデックスまでの要素を対象とします。
Public Sub RemoveRange(minIndex As Long, maxIndex As Long)

    minIndex = IIf(minIndex < LBound(myArr), LBound(myArr), minIndex)
    maxIndex = IIf(maxIndex > myCount - 1, myCount - 1, maxIndex)
   
    If minIndex > maxIndex Then Exit Sub
   
    Dim difference: difference = maxIndex - minIndex
   
    For i = minIndex To myCount - 1
        Dim swapIndex: swapIndex = i + difference + 1
        If swapIndex >= myCount Then Exit For
        myArr(i) = myArr(swapIndex)
    Next i

    For j = myCount - difference - 1 To myCapacity
        myArr(j) = Empty
    Next j

    myCount = myCount - difference - 1

End Sub

'indexに対応する要素を返した上で、リストからその要素を削除します。
Public Function Pop(index As Long)
   
    If index < LBound(myArr) Or UBound(myArr) < index Then
        Pop = Empty: Exit Function
    End If
   
    Pop = myArr(index)
    Call Remove(index)
   
End Function

'引数の値に最初一致したものを取得後削除します。
Public Function PopAt(val)
   
    If myCount = 0 Then Exit Function
   
    Dim i As Long
    For i = LBound(myArr) To myCount - 1
        If myArr(i) = val Then
            PopAt = myArr(i)
            Call Remove(i)
            Exit Function
        End If
    Next i
   
End Function

'特定の範囲を返すと同時に削除して詰めます。(minIndex<=ここ消える<=maxIndex)
'Minが不当に小さい、Maxが不当に大きい場合、最小インデックス、最大インデックスまでの要素を対象とします。
Public Function PopRange(minIndex As Long, maxIndex As Long) As List

    minIndex = IIf(minIndex < LBound(myArr), LBound(myArr), minIndex)
    maxIndex = IIf(maxIndex > myCount - 1, myCount - 1, maxIndex)
   
    If minIndex > maxIndex Then
        Set PopRange = New List
        Exit Function
    End If
   
    Dim difference: difference = maxIndex - minIndex
    Dim result As List: Set result = New List
   
    For index = minIndex To maxIndex
        Call result.Add(myArr(index))
    Next index
   
    For i = minIndex To myCount - 1
        Dim swapIndex: swapIndex = i + difference + 1
        If swapIndex >= myCount Then Exit For
        myArr(i) = myArr(swapIndex)
    Next i

    For j = myCount - difference - 1 To myCapacity
        myArr(j) = Empty
    Next j

    myCount = myCount - difference - 1
   
    Set PopRange = result

End Function

'配列に変換して返します。 配列の要素数はデータ数に切り詰められます。
Public Function ToArray()

    Dim bufArr: bufArr = myArr
    ReDim Preserve bufArr(myCount - 1)
    ToArray = bufArr
   
End Function

'オブジェクトを複製(シャローコピー)します。
Public Function Clone() As List
   
    Dim newlist As List: Set newlist = New List
    newlist.arr = myArr
    newlist.Count = myCount
    newlist.Capacity = myCapacity
    Set Clone = newlist
   
End Function

'指定数先頭から抜き出す
Public Function TakeToNewList(itemCount As Long) As List

    '指定数が要素数を超えている場合クローンを返す
    Dim minIndex As Long: minIndex = LBound(myArr)
    If itemCount + 1 - minIndex > myCount Then
        Set TakeToNewList = Me.Clone()
    Else
        Dim newlist As List: Set newlist = New List
        For i = minIndex To itemCount - 1 + minIndex
            newlist.Add (myArr(i))
        Next i
        Set TakeToNewList = newlist
    End If
   
End Function

'指定数をスキップしてそれ以降を抜き出す
Public Function SkipToNewList(skipCount As Long) As List

    '指定数が要素数を超えている場合nullのアイテムを返す
    If skipCount > myCount Then
        Set SkipToNewList = New List
    Else
        Dim newlist As List: Set newlist = New List
        For i = skipCount To myCount - 1
            newlist.Add (myArr(i))
        Next i
        Set SkipToNewList = newlist
    End If
   
End Function

'昇順でソートします。(実装は多分クイックソートになっているはずです。ロジックいまいち理解していません。
Public Sub SortByAscending(): Call OrderBy: End Sub
Public Sub OrderBy()

    If myCount < 1 Then Exit Sub
    Call QuickSortAscending(LBound(myArr), myCount - 1)
   
End Sub
Private Sub QuickSortAscending(ByVal lowest As Long, ByVal highest As Long)
   
    Dim l As Long: l = lowest
    Dim h As Long: h = highest
    Dim pivot As Long: pivot = myArr(Int((lowest + highest) \ 2))

    Do
        Do While myArr(l) < pivot
            l = l + 1
        Loop
        Do While myArr(h) > pivot
            h = h - 1
        Loop
       
        If l >= h Then Exit Do
       
        Dim buf: buf = myArr(l)
        myArr(l) = myArr(h)
        myArr(h) = buf
        l = l + 1
        h = h - 1
    Loop
   
    If (lowest < l - 1) Then
        Call QuickSortAscending(lowest, l - 1)
    End If
    If (highest > h + 1) Then
        Call QuickSortAscending(h + 1, highest)
    End If
   
End Sub

'降順でソートします。
Public Sub SortByDescending(): Call OrderByDescending: End Sub
Public Sub OrderByDescending()

    If myCount < 1 Then Exit Sub
    Call QuickSortDescending(LBound(myArr), myCount - 1)
   
End Sub

Private Sub QuickSortDescending(ByVal lowest As Long, ByVal highest As Long)

    Dim l As Long: l = lowest
    Dim h As Long: h = highest
    Dim pivot: pivot = myArr(Int((lowest + highest) \ 2))
   
    Do
        Do While myArr(l) > pivot
            l = l + 1
        Loop
        Do While myArr(h) < pivot
            h = h - 1
        Loop
       
        If l >= h Then Exit Do
       
        Dim buf: buf = myArr(l)
        myArr(l) = myArr(h)
        myArr(h) = buf
        l = l + 1
        h = h - 1
    Loop
   
    If (lowest < l - 1) Then
        Call QuickSortDescending(lowest, l - 1)
    End If
    If (highest > h + 1) Then
        Call QuickSortDescending(h + 1, highest)
    End If
   
End Sub

'格納されている値を反転します。
Public Function Reverse()

    If myCount < 1 Then Exit Function
    Dim maxIndxNo As Long: maxIndxNo = myCount - 1
    Dim buf(): ReDim buf(0 To maxIndxNo)
   
    Dim counter As Long: counter = maxIndxNo
   
    For i = 0 To maxIndxNo
        buf(counter) = myArr(i)
        counter = counter - 1
    Next i
   
    myArr = buf
   
End Function

' 値をシャッフルします。精度はいまいちかもしれません。精度が欲しければメルセンヌツイスターとか良いらしいので実装して下さい。自分は死なないならやりません。
Public Sub Randamize()

    Dim maxIndxNo As Long: maxIndxNo = myCount - 1
    Dim i As Long, rndIndex As Variant, tmp As Variant
    For i = 0 To maxIndxNo
        rndIndex = Int(maxIndxNo * Rnd)
        tmp = myArr(i)
        myArr(i) = myArr(rndIndex)
        myArr(rndIndex) = tmp
    Next
   
End Sub
 
'数値を文字列に変換し、その対象がリストに含まれるか検査します。
'containsの期待される動作的にワイルドカード対応のlikeより=の検査の方が適切かなと。contains_Likeみたいな方が良い?
Public Function StringContains(str As String) As Boolean
       
    For Each elm In myArr
        If str = CStr(elm) Then
            StringContains = True
            Exit Function
        End If
    Next
   
    StringContains = False
   
End Function

'StringBuilderのようにコレクションを高速に結合してStringを返します。
Public Function ToBuildString() As String

    Dim strCount As Long: strCount = 1
    
    For Each elm In myArr
        strCount = strCount + Len(elm)
    Next
    
    If strCount = 1 Then
        ToBuildString = Empty
        Exit Function
    End If
    
    Dim result As String: result = Space(strCount - 1)
    
    Dim chrNumber As Long: chrNumber = 1
    Dim i As Long: i = 1
    For Each elm In myArr
        Mid(result, chrNumber) = elm
        chrNumber = chrNumber + Len(elm)
        If i = myCount Then Exit For
        i = i + 1
    Next

    ToBuildString = result


End Function

'StringBuilderのようにコレクションを高速に結合してStringを返します。
'要素間にdelimiterで指定した文字列を挿入します。
Public Function ToBuildStringWithDelimiter(delimiter As String)

    Dim strCount As Long: strCount = 1
    
    For Each elm In myArr
        strCount = strCount + Len(elm)
    Next
    
    If strCount = 1 Then
        ToBuildStringWithDelimiter = Empty
        Exit Function
    End If
    
    Dim delimiterSize As Long: delimiterSize = Len(delimiter)
    Dim result As String
    result = Space(strCount + delimiterSize * myCount - 1)
    
    Dim chrNumber As Long: chrNumber = 1
    Dim i As Long: i = 1
    For Each elm In myArr
        Mid(result, chrNumber) = elm
        Mid(result, chrNumber + Len(elm)) = delimiter
        chrNumber = chrNumber + delimiterSize + Len(elm)
        If i = myCount Then Exit For
        i = i + 1
    Next

    ToBuildStringWithDelimiter = Left(result, Len(result) - delimiterSize)

End Function

以下は値が数値が格納されていることを前提とした計算メソッドです。必要であれば追加してください。
VBAのWorksheetFunctionは65536個より大きい値に適用できません(2次元配列にすれば1048576個までというのを聞いたことがありますが試していません)

'リストに数値しか入っていないこと前提のメソッド群です
'探しやすいようにだったり、邪魔にならないようにMathと頭につけた
'※実行効率よくない
'※※要素数が65536を超えるとworksheetfunctionは動かない

'合計値を取得します。
Public Function Math_Sum()
    If myCount < 65535 Then
        Math_Sum = WorksheetFunction.sum(myArr)
    Else
        Dim buf
        For Each elm In myArr
            buf = buf + elm
        Next
        Math_Sum = buf
    End If
End Function

'平均値を取得します。
Public Function Math_Average()
    If myCount < 65535 Then
        Math_Average = WorksheetFunction.Average(myArr)
    Else
        Dim buf
        Dim counter As Long: counter = 1
        For i = LBound(myArr) To myCount - 1
            buf = buf + myArr(i)
        Next
        Math_Average = buf / myCount
    End If
End Function

'中央値を取得します。実行効率はうんこです･･･書き直して❤
Public Function Math_Median()
    If myCount < 65535 Then
        Math_Median = WorksheetFunction.Median(myArr)
    Else
        Dim newlist As List
        Set newlist = Me.Clone
        newlist.OrderBy
        If (myCount Mod 2 = 0) Then
            Math_Median = newlist.arr((newlist.Count) / 2 - 1)
        Else
            Math_Median = (newlist.arr(WorksheetFunction.RoundUp((newlist.Count) / 2, 0) - 1) _
                                + newlist.arr(WorksheetFunction.RoundDown((newlist.Count) / 2, 0) - 1)) _
                                / 2
        End If
    End If
End Function

'最大値を返します。
Public Function Math_Max()
   
    If myCount < 65535 Then
        Math_Max = WorksheetFunction.max(myArr)
    Else
   
    Dim max
    For Each elm In Me.ToArray
        max = IIf(elm > max, elm, max)
    Next elm
    Math_Max = max
    End If
   
End Function

'最小値を返します。
Public Function Math_Min()
   
    If myCount < 65535 Then
        Math_Min = WorksheetFunction.Min(myArr)
    Else
   
    Dim Min: Min = myArr(0)
    For Each elm In Me.ToArray
        Min = IIf(elm < Min, elm, Min)
    Next elm
    Math_Min = Min
    End If
   
End Function

'母集団の標準偏差を求めます
Public Function Math_StDevP()
   
    If myCount < 65535 Then
        Math_StDevP = WorksheetFunction.StDev(myArr)
    Else
   
        Dim buf As Variant
        Dim sum As Double
        Dim avg As Double
        Dim v As Double
       
        Dim arr: arr = Me.ToArray
        For Each buf In arr
            sum = sum + buf
        Next
       
        avg = sum / myCount
       
        For Each buf In arr
            v = v + (avg - buf) ^ 2
        Next
        Math_StDevP = Sqr(v / myCount)
    End If
   
End Function

以下おそらくWindowsでしか動かない機能です。scripting.Dictionaryに関してはクラスで作っておられる方がいるらしいので
それを使用すれば実装できるかもしれません。(Win環境しか無く試しておりません)
https://github.com/VBA-tools/VBA-Dictionary

'一意の値(ユニーク値)にフィルターして新しいリストとして返します。
Public Function DistinctToNewList() As List

    Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
    Dim newlist As List: Set newlist = New List
   
    For Each elm In myArr
        dic(elm) = 0
    Next
   
    For Each Key In dic.Keys
        newlist.Add (Key)
    Next
   
    Set DistinctToNewList = newlist

End Function

'数値を文字列に変換し、対象文字列がリストに含まれるか正規表現で検査します。
'一応作っただけなので、どういう時に役に立つか考えていません。
Public Function StringContains_RegExp(Pattern As String) As Boolean

    Dim regExp As regExp
    Set regExp = CreateObject("VBScript.RegExp")
          regExp.Pattern = Pattern
       
    For Each element In myArr
        If regExp.Test(element) Then
            StringContains_RegExp = True
            Exit Function
        End If
    Next
   
    ContainsRegExp = False
   
End Function

'最頻値を1つとってきます。なんかworksheetfunction動きません。
'重複する値が極めて多いかほとんど重複しない場合はとても遅いです。
Public Function Math_ModeSingle()
   
    Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
    '数値,個数の辞書を作る
    For Each elm In Me.arr
        If Not (IsEmpty(elm)) Then
            dic(elm) = dic(elm) + 1
        End If
    Next
   
    If dic.Count = 0 Then Exit Function
   
    '最大の個数を調べる
    Dim maxCounter As Long
    Dim val As Long
    For Each elm In dic.Items
        maxCounter = IIf(maxCounter < elm, elm, maxCounter)
    Next elm

    '最大値と一致する値を返す
    For Each elm In dic.Keys
        If dic(elm) = maxCounter Then
            Math_ModeSingle = elm
            Exit Function
        End If
    Next
   
End Function

'最頻値を配列で返します。なんかworksheetfunction動きません。
'重複する値が極めて多いかほとんど重複しない場合はとても遅いです。
'もっと良い実装で誰か作って()
Public Function Math_ModeMulti()
   
    Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
    '数値,個数の辞書を作る
    For Each elm In Me.arr
        If Not (IsEmpty(elm)) Then
            dic(elm) = dic(elm) + 1
        End If
    Next
   
    If dic.Count = 0 Then Exit Function
   
    '最大の個数を調べる
    Dim maxCounter As Long
    Dim val As Long
    For Each elm In dic.Items
        maxCounter = IIf(maxCounter < elm, elm, maxCounter)
    Next elm

    '最大値と一致する値を入れる
    Dim newlist As List: Set newlist = New List
    For Each elm In dic.Keys
        If dic(elm) = maxCounter Then
            Call newlist.Add(elm)
        End If
    Next
   
    Math_ModeMulti = newlist.ToArray
   
End Function