2019年7月 – VBA SQL

2019年7月24日2019年7月30日

選択ソート　二次元配列

ついでに選択ソートも

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

2019年7月24日2019年8月21日

QuickSort 二次元配列

もともとは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

2019年7月12日2019年7月30日

VBAで配列をソート　Quicksort

quicksortも作ってみました
無限ループに何度もはまりました
コード表示のプラグインも入れてみました

ちなみにquicksortのアルゴリズムはここ
再帰プロシージャはここを参考にさせてもらいました。

Public Function QuickSort(ParamAry As Variant) As Variant

Dim newAry() As String
Dim I As Long
Dim j As Long
Dim K As Long
Dim Anker As Long

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

If Not UBound(ParamAry) >= 0 Then
Exit Function
End If

    Anker = CLng(ParamAry(0))
For I = 1 To UBound(ParamAry)

    If ParamAry(I) < Anker Then
        ReDim Preserve TopAry(j)
        TopAry(j) = ParamAry(I)
        j = j + 1

    End If

    If ParamAry(I) >= Anker Then
        ReDim Preserve BtmAry(K)
        BtmAry(K) = ParamAry(I)
        K = K + 1
    End If
Next I
    
Dim n As Long
n = 0
If j > 0 Then
    TopAry = QuickSort(TopAry)
    For I = 0 To UBound(TopAry)
        ReDim Preserve newAry(n)
        newAry(n) = TopAry(I)
        n = n + 1
    Next I
End If
        ReDim Preserve newAry(n)
        newAry(n) = Anker
        n = n + 1
If K > 0 Then
    BtmAry = QuickSort(BtmAry)
    For I = 0 To UBound(BtmAry)
        ReDim Preserve newAry(n)
        newAry(n) = BtmAry(I)
        n = n + 1
    Next I
End If

    
    QuickSort = newAry
    

'If UBound(ParamAry) = 1 Then
'Exit Function
'End If

    

End Function

Public Function QuickSort(ParamAry As Variant) As Variant

Dim newAry() As String

Dim I As Long

Dim j As Long

Dim K As Long

Dim Anker As Long

Dim TopAry() As String

Dim BtmAry() As String

j = 0

K = 0

If Not UBound(ParamAry) >= 0 Then

Exit Function

End If

Anker = CLng(ParamAry(0))

For I = 1 To UBound(ParamAry)

If ParamAry(I) < Anker Then

ReDim Preserve TopAry(j)

TopAry(j) = ParamAry(I)

j = j + 1

End If

If ParamAry(I) >= Anker Then

ReDim Preserve BtmAry(K)

BtmAry(K) = ParamAry(I)

K = K + 1

End If

Next I

Dim n As Long

n = 0

If j > 0 Then

TopAry = QuickSort(TopAry)

For I = 0 To UBound(TopAry)

ReDim Preserve newAry(n)

newAry(n) = TopAry(I)

n = n + 1

Next I

End If

ReDim Preserve newAry(n)

newAry(n) = Anker

n = n + 1

If K > 0 Then

BtmAry = QuickSort(BtmAry)

For I = 0 To UBound(BtmAry)

ReDim Preserve newAry(n)

newAry(n) = BtmAry(I)

n = n + 1

Next I

End If

QuickSort = newAry

'If UBound(ParamAry) = 1 Then

'Exit Function

'End If

End Function

最速です

2019年7月9日2020年6月24日

VBAで配列をソート　テーブルを使う

テーブルに入れると言う手もあります
これが一番簡単
SQLserverとつながっているなら一時テーブルに入れ込む

Public Function TableSort(Ary As Variant) As Variant
'Dim Ary
'Ary = Array("5", "4", "1", "2", "900", "888")

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.ConnectionString = "接続文字列"
cn.Open

Dim I As Long
I = 0
cn.Execute "drop table if exists #AryT"
cn.Execute "select " & CLng(Ary(I)) & "as C into #AryT"

For I = 1 To UBound(Ary)
    cn.Execute "insert into #AryT(C) values(" & CLng(Ary(I)) & ")"
Next I

rs.Open "select C from #AryT order by C asc", cn, adOpenStatic, adLockOptimistic

rs.MoveFirst

I = 0
Do Until rs.EOF
    Ary(I) = rs!C
    rs.MoveNext
    I = I + 1
Loop

'For I = 0 To UBound(Ary)
'    Debug.Print Ary(I)
'Next

TableSort = Ary

 rs.Close
 cn.Close

End Function

Public Function TableSort(Ary As Variant) As Variant

'Dim Ary

'Ary = Array("5", "4", "1", "2", "900", "888")

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset

Set cn = New ADODB.Connection

Set rs = New ADODB.Recordset

cn.ConnectionString = "接続文字列"

cn.Open

Dim I As Long

I = 0

cn.Execute "drop table if exists #AryT"

cn.Execute "select " & CLng(Ary(I)) & "as C into #AryT"

For I = 1 To UBound(Ary)

cn.Execute "insert into #AryT(C) values(" & CLng(Ary(I)) & ")"

Next I

rs.Open "select C from #AryT order by C asc", cn, adOpenStatic, adLockOptimistic

rs.MoveFirst

I = 0

Do Until rs.EOF

Ary(I) = rs!C

rs.MoveNext

I = I + 1

Loop

'For I = 0 To UBound(Ary)

' Debug.Print Ary(I)

'Next

TableSort = Ary

rs.Close

cn.Close

End Function

2019年7月9日2019年7月30日

VBAで配列をソート　選択ソート

バブルソートは時間がかかる
quick sortはササッと書くのは難しい
ので選択ソート

Public Function SelectSort(Ary As Variant) As Variant

'Dim Ary
'Ary = Array("0", "1", "1", "2", "900", "888")

Dim I As Long, j As Long
Dim Min As Long, flag As Long
Dim newA As String, newB As String, Mark As Long

For I = 0 To UBound(Ary) - 1
    flag = CLng(Ary(I))
    Min = CLng(Ary(I))
    Mark = I
    
    For j = 1 To UBound(Ary) - I
        If Min > CLng(Ary(I + j)) Then
            Min = CLng(Ary(I + j))
            Mark = I + j
        End If
    Next j
    
    newA = CStr(Min)
    newB = CStr(flag)
    
If Not Mark = I Then
    Ary(I) = newA
    Ary(Mark) = newB
End If
Next I

'For I = 0 To UBound(Ary)
'    Debug.Print Ary(I)
'Next

SelectSort = Ary
 
End Function

Public Function SelectSort(Ary As Variant) As Variant

'Dim Ary

'Ary = Array("0", "1", "1", "2", "900", "888")

Dim I As Long, j As Long

Dim Min As Long, flag As Long

Dim newA As String, newB As String, Mark As Long

For I = 0 To UBound(Ary) - 1

flag = CLng(Ary(I))

Min = CLng(Ary(I))

Mark = I

For j = 1 To UBound(Ary) - I

If Min > CLng(Ary(I + j)) Then

Min = CLng(Ary(I + j))

Mark = I + j

End If

Next j

newA = CStr(Min)

newB = CStr(flag)

If Not Mark = I Then

Ary(I) = newA

Ary(Mark) = newB

End If

Next I

'For I = 0 To UBound(Ary)

' Debug.Print Ary(I)

'Next

SelectSort = Ary

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