2019年7月24日

ついでに選択ソートも

Dim Ary() As String
For I = 0 To myDIC.Count - 1
ReDim Preserve Ary(1, I)
    Ary(0, I) = myDIC.keys()(I)
    Ary(1, I) = myDIC.items()(I)
Next I
'Dictionaryから二次元配列に
'以下ソート
Dim i As Long, j As Long
Dim Max As Double, flag As Double
Dim newA0 As Long, newB0 As Long _
, newA1 As Double, newB1 As Double, Mark As Long

For I = 0 To UBound(Ary, 2) - 1
    flag = CDbl(Ary(1, I))
    Max = CDbl(Ary(1, I))
    Mark = I

    For j = 1 To UBound(Ary, 2) - I
        If Max < CDbl(Ary(1, I + j)) Then
            Max = CDbl(Ary(1, I + j))
            Mark = I + j
        End If
    Next j

    newA0 = Ary(0, Mark)
    newA1 = CStr(Max)
    newB0 = Ary(0, I)
    newB1 = CStr(flag)

If Not Mark = I Then
    Ary(0, I) = newA0
    Ary(1, I) = newA1
    Ary(0, Mark) = newB0
    Ary(1, Mark) = newB1
End If
Next I

Dim Ary() As String

For I = 0 To myDIC.Count - 1

ReDim Preserve Ary(1, I)

Ary(0, I) = myDIC.keys()(I)

Ary(1, I) = myDIC.items()(I)

Next I

'Dictionaryから二次元配列に

'以下ソート

Dim i As Long, j As Long

Dim Max As Double, flag As Double

Dim newA0 As Long, newB0 As Long _

, newA1 As Double, newB1 As Double, Mark As Long

For I = 0 To UBound(Ary, 2) - 1

flag = CDbl(Ary(1, I))

Max = CDbl(Ary(1, I))

Mark = I

For j = 1 To UBound(Ary, 2) - I

If Max < CDbl(Ary(1, I + j)) Then

Max = CDbl(Ary(1, I + j))

Mark = I + j

End If

Next j

newA0 = Ary(0, Mark)

newA1 = CStr(Max)

newB0 = Ary(0, I)

newB1 = CStr(flag)

If Not Mark = I Then

Ary(0, I) = newA0

Ary(1, I) = newA1

Ary(0, Mark) = newB0

Ary(1, Mark) = newB1

End If

Next I

もともとはDictionaryでソートする必要があったので配列のソートを調べたのでした
dictionaryに入っているkeyとitemを二次元配列にしてソートする
もっと良い方法があると思いますが・・とりあえず
関数化したけど要素で型変換必要なので意味がなかった

Public Function QuickSortB(ByRef ParamAry As Variant) As Variant

'paramaryは二次元配列

Dim newAry() As String
Dim I As Long
Dim j As Long
Dim K As Long
Dim Anker As Date　'ソートしたい
Dim Bnker As Long

Dim TopAry() As String
Dim BtmAry() As String
j = 0
K = 0

If Not UBound(ParamAry, 2) >= 0 Then 'トラップ
Exit Function
End If

    Bnker = CLng(ParamAry(0, 0))　
    Anker = CDate(ParamAry(1, 0))　
For I = 1 To UBound(ParamAry, 2)

    If CDate(ParamAry(1, I)) < Anker Then
        ReDim Preserve TopAry(1, j)
        TopAry(0, j) = ParamAry(0, I)
        TopAry(1, j) = ParamAry(1, I)

        j = j + 1

    End If

    If CDate(ParamAry(1, I)) >= Anker Then
        ReDim Preserve BtmAry(1, K)
        BtmAry(0, K) = ParamAry(0, I)
        BtmAry(1, K) = ParamAry(1, I)
        K = K + 1
    End If
Next I

Dim n As Long
n = 0
If j &gt; 0 Then
    TopAry = QuickSortB(TopAry)
    For I = 0 To UBound(TopAry, 2)
        ReDim Preserve newAry(1, n)
        newAry(0, n) = TopAry(0, I)
        newAry(1, n) = TopAry(1, I)

        n = n + 1
    Next I
End If
        ReDim Preserve newAry(1, n)
        newAry(0, n) = Bnker
        newAry(1, n) = Anker
        
        n = n + 1
If K &gt; 0 Then
    BtmAry = QuickSortB(BtmAry)
    For I = 0 To UBound(BtmAry, 2)
        ReDim Preserve newAry(1, n)
        newAry(0, n) = BtmAry(0, I)
        newAry(1, n) = BtmAry(1, I)
        n = n + 1
    Next I
End If
QuickSortB = newAry

End Function

Public Function QuickSortB(ByRef ParamAry As Variant) As Variant

'paramaryは二次元配列

Dim newAry() As String

Dim I As Long

Dim j As Long

Dim K As Long

Dim Anker As Date　'ソートしたい

Dim Bnker As Long

Dim TopAry() As String

Dim BtmAry() As String

j = 0

K = 0

If Not UBound(ParamAry, 2) >= 0 Then 'トラップ

Exit Function

End If

Bnker = CLng(ParamAry(0, 0))　

Anker = CDate(ParamAry(1, 0))　

For I = 1 To UBound(ParamAry, 2)

If CDate(ParamAry(1, I)) < Anker Then

ReDim Preserve TopAry(1, j)

TopAry(0, j) = ParamAry(0, I)

TopAry(1, j) = ParamAry(1, I)

j = j + 1

End If

If CDate(ParamAry(1, I)) >= Anker Then

ReDim Preserve BtmAry(1, K)

BtmAry(0, K) = ParamAry(0, I)

BtmAry(1, K) = ParamAry(1, I)

K = K + 1

End If

Next I

Dim n As Long

n = 0

If j > 0 Then

TopAry = QuickSortB(TopAry)

For I = 0 To UBound(TopAry, 2)

ReDim Preserve newAry(1, n)

newAry(0, n) = TopAry(0, I)

newAry(1, n) = TopAry(1, I)

n = n + 1

Next I

End If

ReDim Preserve newAry(1, n)

newAry(0, n) = Bnker

newAry(1, n) = Anker

n = n + 1

If K > 0 Then

BtmAry = QuickSortB(BtmAry)

For I = 0 To UBound(BtmAry, 2)

ReDim Preserve newAry(1, n)

newAry(0, n) = BtmAry(0, I)

newAry(1, n) = BtmAry(1, I)

n = n + 1

Next I

End If

QuickSortB = newAry

End Function

月	火	水	木	金	土	日
« 6月				8月 »
1	2	3	4	5	6	7
8	9	10	11	12	13	14
15	16	17	18	19	20	21
22	23	24	25	26	27	28
29	30	31

日: 2019年7月24日

選択ソート　二次元配列

QuickSort 二次元配列