kurukuru-papaのブログ

主に、ソフトウェア開発に関連したメモを書き溜めたいと思います。

ハッシュテーブル(連想配列)のクラスを作成しました

VBAには、ハッシュテーブルのようなデータ構造がありません。それでも、ハッシュテーブルがあると便利な事がありますので、ライブラリを自作してみました。

処理を簡単にするため、Excelシートを使ってハッシュテーブルを実現しました。ソースは下記のようになりました。

使い方を簡単に書いておきます。

1.ハッシュテーブルインスタンス生成
インスタンス生成は、次のように行います。

    Dim hashTable As New HashTableClass
    Call hashTable.Initialize("マクロ用ハッシュテーブル", 1, 1)
    Call hashTable.Clear

インスタンスを生成した際は、Initializeプロシージャを必ず呼び出して、初期化処理を行ってください。
Initializeプロシージャの第1引数には、ユニークな名前を指定してください。指定したシートが存在しない場合は自動的に作成されます。第2,3引数にはシート内で使用するセルの位置を指定します。基本的には1,1でよいです。
さらに、VBAの前回起動時の値を削除するため、Clearプロシージャを呼び出します。

2.データアクセス
GetValue、SetValueプロシージャを使用してデータにアクセスしてください。全てのデータは文字列として扱われるため、必要に応じて型変換を行ってください。

以上で簡単なライブラリの簡単な説明を終わります。

' ハッシュクラス
'
' 指定されたシートを使用して連想配列を実現するクラスです。
'
' 新規作成:2008/03/16

Option Explicit

Private sheet As Worksheet
Private startCell As Range

' コンストラクタ
Private Sub Class_Initialize()
End Sub

' 初期化処理
' コンストラクタには引数を渡せないみたいだったので、
' このSubプロシージャを作成しました。
Public Sub Initialize(sheetName As String, startRow As Integer, startColumn As Integer)
    Dim tmpSheet As Worksheet
    
    ' シートの存在チェック
    For Each tmpSheet In Worksheets
        If tmpSheet.name = sheetName Then
            Set sheet = tmpSheet
        End If
    Next
    
    ' シートがなければ作成
    If sheet Is Nothing Then
        Worksheets.Add
        ActiveSheet.name = sheetName
        Set sheet = ActiveSheet
    End If
    
    Set startCell = sheet.Cells(startRow, startColumn)
End Sub

' クリアする
Public Sub Clear()
    ' シートの内容をクリアする
    sheet.Cells.ClearContents
End Sub

' 連想配列から指定キーの値を取得する。
' key - キー文字列
' return - キーが存在した場合、対応する値を返却。
'          キーが見つからなかった場合、Nothingを返却。
Public Function GetValue(key As String) As String
    Dim cell As Range
    Set cell = GetCell(key)
    GetValue = cell.value
End Function

' 連想配列へ値を設定する。
' key - キー文字列
' value - 設定する値
Public Sub SetValue(key As String, value As String)
    Dim cell As Range
    Set cell = GetCell(key)
    cell.value = value
End Sub

' 連想配列から指定キーのセルを取得する。
' 指定キーが存在しない場合、要素を追加してセルを返却する。
' key - キー文字列
' return - キーが存在した場合、対応する値を返却。
'          キーが見つからなかった場合、Nothingを返却。
Private Function GetCell(key As String) As Range
    Dim cell As Range
    Dim keyBuf As String
    
    Set cell = startCell
    Do While True
        keyBuf = cell.value
        If keyBuf = "" Then
            cell.value = key
            Exit Do
        End If
        If keyBuf = key Then
            Exit Do
        End If
        
        Set cell = cell.Offset(1, 0)
    Loop
    
    Set GetCell = cell.Offset(0, 1)
End Function