基数変換

今回は、基数変換です。10進数をn進数に変換します（16進数まで）。
普通にループで処理すればいいんですけど、あえて再帰で。

'基数変換（10進数をn進数に変換する）
Private Sub RadixConversionTest()
    Debug.Print RadixConversion(777, 16)
End Sub

Private Function RadixConversion(ByVal num As Long, ByVal Radix As Long) As String
    Dim Quotient As Long
    Dim Remainder As Long
    
    Remainder = num Mod Radix
    Quotient = num \ Radix
    If Quotient = 0 Then
        RadixConversion = GetHexString(Remainder)
    Else
        RadixConversion = RadixConversion(Quotient, Radix) & GetHexString(Remainder)
    End If
End Function

Private Function GetHexString(ByVal num As Long) As String
    Dim temp As Variant
    temp = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
    GetHexString = temp(num)
End Function

ループ処理バージョンは、今度アップします（まだ書いてない）

クイックソート（配列バージョン）

始めたばかりですが、息切れ始まった感じです。
とりあえず、クイックソートの配列バージョンです。

正直、エラー処理などもっとスマートにできる気がしますが、公開します。

Private Sub QuickSortArrayTest()
    Dim temp As Variant
    Dim data(0 To 3) As Variant
    
    data(0) = 4
    data(1) = 3
    data(2) = 2
    data(3) = 1
        
    Debug.Print QuickSortArray(data)
End Sub

Private Function QuickSortArray(ByRef data() As Variant) As Variant
    Dim pivot As Variant
    Dim less() As Variant
    Dim greater() As Variant
    Dim num As Long
    Dim i As Long
    
    On Error Resume Next
    num = UBound(data)
    If Err.Number <> 0 Then
        QuickSortArray = vbNullString
        Exit Function
    End If
    On Error GoTo 0
    If UBound(data) < 1 Then
        QuickSortArray = data(0)
    Else
        pivot = data(0)
        For i = LBound(data) + 1 To UBound(data)
            If data(i) <= pivot Then
                On Error Resume Next
                ReDim Preserve less(UBound(less) + 1)
                If Err.Number = 0 Then
                    'Do Nothing
                Else
                    ReDim less(0)
                End If
                On Error GoTo 0
                less(UBound(less)) = data(i)
            ElseIf data(i) > pivot Then
                On Error Resume Next
                ReDim Preserve greater(UBound(greater) + 1)
                If Err.Number = 0 Then
                    'Do Nothing
                Else
                    ReDim greater(0)
                End If
                greater(UBound(greater)) = data(i)
                On Error GoTo 0
            End If
        Next
        QuickSortArray = QuickSortArray(less) & pivot & QuickSortArray(greater)
    End If
End Function

二分探索（VBA）

今回は、二分探索です。

配列の要素を検索して、指定した値が配列の何番目にあるか調べます。
相変わらずコメント無くてすみません。

Private Sub BinarySearchTest()
    Dim vList(1 To 5) As Long
    
    vList(1) = 1
    vList(2) = 5
    vList(3) = 10
    vList(4) = 14
    vList(5) = 20
    
    Debug.Print BinarySearch(vList, 10)
End Sub

Private Function BinarySearch(ByRef vList() As Long, ByVal vTarget As Long) As Long
    Dim vHigh As Long
    Dim vRow As Long
    Dim vMid As Long
    
    vHigh = UBound(vList)
    vRow = LBound(vList)
    
    Do Until vRow > vHigh
        vMid = (vHigh + vRow) / 2
        If vList(vMid) = vTarget Then
            BinarySearch = vMid
            Exit Do
        ElseIf vList(vMid) < vTarget Then
            vRow = vRow + 1
        Else
            vHigh = vMid - 1
        End If
    Loop
End Function

挿入ソート（VBA）

先日、クイックソートを載せたので、今回は挿入ソートです。
今回もCollection使ってます。

コメントが無いのはすみません。

Private Sub InsertionSortTest()
    Dim temp As Collection
    Dim i As Long
    
    Set temp = New Collection
    temp.Add 4
    temp.Add 3
    temp.Add 2
    temp.Add 1
    
    Set temp = InsertionSort(temp)
    For i = 1 To temp.Count
        Debug.Print temp.Item(i)
    Next
    
End Sub

Private Function InsertionSort(ByVal data As Collection) As Collection
    Dim temp As Variant
    Dim i As Long, j As Long
    
    For i = 2 To data.Count
        j = i
        Do While j > 1
            If data.Item(j - 1) < data.Item(i) Then
                Exit Do
            End If
            j = j - 1
        Loop
        
        If i = j Then
            'Do Nothing
        Else
            temp = data.Item(i)
            data.Remove i
            data.Add temp, , Before:=(j)
        End If
    Next
        
    Set InsertionSort = data
End Function

アルゴリズムのお勉強

頭のトレーニング用に最近買った本です。 

なっとく！アルゴリズム

 この書籍、なかなか読みやすく分かりやすかったです。

サンプルコードはPythonで書かれてますが、Python知らなくても読めるでしょう。

さて、この書籍で紹介されていたコードを参考にちょっとVBAで書いてみました。

クイックソートです。

Private Sub QuickSortCollectionTest()
    Dim temp As Variant
    Dim data As Collection
    Dim i As Long

    Set data = New Collection
    data.Add 6
    data.Add 5
    data.Add 2
    data.Add 1

    Debug.Print QuickSortCollection(data)
End Sub

Private Function QuickSortCollection(ByVal data As Collection) As Variant
    Dim pivot As Variant
    Dim less As Collection
    Dim greater As Collection
    Dim i As Long

    Set less = New Collection
    Set greater = New Collection

    If data.Count = 0 Then
        QuickSortCollection = vbNullString
    ElseIf data.Count < 2 Then
        QuickSortCollection = data.Item(1)
    Else
        pivot = data.Item(1)
        For i = 2 To data.Count
            If data.Item(i) <= pivot Then
                less.Add data.Item(i)
            ElseIf data.Item(i) > pivot Then
                greater.Add data.Item(i)
            End If
        Next
        QuickSortCollection = QuickSortCollection(less) & pivot & QuickSortCollection(greater)
    End If
End Function

ここでは、配列ではなくてCollectionを使っています。もちろん、配列で書いてもいいんで、配列バージョンを書いたらアップします（いつになるかわかりませんが）。

今日から始めます

最近、勉強してもすぐ忘れるので、備忘録的に始めます。

VBAネタが多くなりそうです。