インストールレスプログラミング( ´ー`)

VBA , JavaScript , HTAなど 365アプリはインストール必要ですが、仕事に無いケースはほぼないから(・_・;)

バブルソートについて理解を進める。

バブルソートへの理解がちゃんとできていないので,(;´▽`A``わたしはここからです。

 ① ② ③ ④
 3 1 4 2

4つの数字をバブルソートで並べる。昇順で考える。
最初に④の数字を決める。 ①と②比較 ②と③比較 ③と④比較と順番に進めて ④が確定 この場合は4が押し出される。
次は,③の数字を決める。 ①と②比較 ②と③比較  ③が確定 この場合は3が押し出される。
次は,②の数字を決める。 ①と②比較  ①も②も確定して終了 ①は1,②は2か。

ふむふむ

4つの数字について決めるのに3段階  Col.Count の数の順を決めるには, 外側のループは文字はiとして Col.Count-1 回でいいということか。
For i=1 to Col.Count-1 ~ Next でよさそうだ

中身のループは,常に①と②の比較からはじめ,その時の残っている要素数-1回で済むようだ。 隣り合っている数字を比べればいいようだ。

つまり,比較する対象は jで扱うとすると jとj+1を比較していく。
1つずつ要素は決まっていき,その分減っていくから,内側のループは Col.Count - i回と言えそうだ。
つまり,内側のループは
for j=1 to Col.Count-i ~ Next かな。

まとめると

For i=1 to Col.Count-1
    For j=1 to Col.Count-i
        要素jと要素j+1を比較して,逆ならSwap
    Next
Next

こんな感じでいいとわたしは解釈してみた。

それに合わせて,前回までのものを書き直してみる

Option Explicit

Function GetDataAsCollection() As Collection
    Dim Arr: Arr = GetDataAsArray
    Dim Col As Collection: Set Col = New Collection
    Dim i, j, k
    For i = LBound(Arr, 1) + 1 To UBound(Arr, 1)
        With New person
            For j = 1 To 列数
                .LetParameter j, Arr(i, j)
            Next
            Col.Add .Self
        End With
    Next
    Set GetDataAsCollection = Col
End Function

Function GetDataAsArray() As Variant
    GetDataAsArray = ThisWorkbook.Worksheets("データ").Range("a1").CurrentRegion.value
End Function

Sub CollectionSwap(Col As Collection, Index1 As Long, Index2 As Long)
    Dim Item1 As Variant, Item2 As Variant
    Set Item1 = Col.Item(Index1)
    Set Item2 = Col.Item(Index2)
    
    Col.Add Item1, after:=Index2
    Col.Remove Index2
    Col.Add Item2, after:=Index1
    Col.Remove Index1
End Sub


Function Report(Col As Collection) As Variant

    Dim p As person, Rangearray()
    Dim i As Long, n As Long: n = 1
    ReDim Rangearray(1 To Col.Count, 1 To 列数)
    
    For Each p In Col
        For i = 1 To 列数
            Rangearray(n, i) = p.GetParameter(i)
        Next
        n = n + 1
    Next
    Report = Rangearray
End Function
Sub メイン処理()
    Dim Col As Collection: Set Col = GetDataAsCollection
    
    'CSort Col, c.カテゴリ, False '第3のキー

    CSort Col, c.数値1, False, c.数値2, False
    
    'ソート結果出力
    ThisWorkbook.Worksheets("出力").Range("a1").Resize(1, 列数).value = ThisWorkbook.Worksheets("データ").Range("a1").Resize(1, 列数).value
    ThisWorkbook.Worksheets("出力").Range("a2").Resize(Col.Count, 列数) = Report(Col)
End Sub

Sub CSort(Col As Collection, Key1 As String, Key1昇順 As Boolean, Optional Key2 As String, Optional Key2昇順 As Boolean)
    Dim p1 As person, p2 As person
    Dim p1k1 As Variant, p2k1 As Variant, p1k2 As Variant, p2k2 As Variant
    'バブルソート
    Dim i As Long, j As Long
    For i = 1 To Col.Count - 1
        For j = 1 To Col.Count - i
            Set p1 = Col(j)
            Set p2 = Col(j + 1)
            
            If IsNumeric(Key1) Then
                p1k1 = CallByName(p1, "GetParameter", VbMethod, Key1)
                p2k1 = CallByName(p2, "GetParameter", VbMethod, Key1)
            Else
                p1k1 = CallByName(p1, Key1, VbGet)
                p2k1 = CallByName(p2, Key1, VbGet)
            End If
            
            If Key2 <> "" Then
                If IsNumeric(Key2) Then
                    p1k2 = CallByName(p1, "GetParameter", VbMethod, Key2)
                    p2k2 = CallByName(p2, "GetParameter", VbMethod, Key2)
                Else
                    p1k2 = CallByName(p1, Key2, VbGet)
                    p2k2 = CallByName(p2, Key2, VbGet)
                End If
            End If
            
            Dim flag As Boolean: flag = False
            
            If Key2 = "" Then
                If IsGreater(Key1昇順, p1k1, p2k1) Then flag = Not flag
            Else
                If IsGreater(Key1昇順, p1k1, p2k1) Then
                    flag = Not flag
                ElseIf p1k1 = p2k1 Then
                    If IsGreater(Key2昇順, p1k2, p2k2) Then
                        flag = Not flag
                    End If
                End If
            End If
            If flag Then CollectionSwap Col, j, j + 1
        Next j
    Next i

End Sub

Function IsGreater(which, A, B) As Boolean
    Select Case which
        Case True: IsGreater = A > B
        Case False: IsGreater = A < B
    End Select
End Function

数度試したけど,今のところ問題視していた入れ替わりは起こってはいなさそうだ。

本当かなぁ。

引き続き検証中。。

第3のキー 今はコメントアウトしているけど,それを先に回していたらたしかに,動いていた。

たくさんキーが使えるソートになってるのかなぁ。

くどいけど検証中(;´▽`A``