昨日の記事から構想を練って発展させた結果、ついにEXCELでハッシュテーブルを実装することができました。
Excelの任意の表領域を選んで、Hashtableクラスを New するだけで、お手軽簡単にハッシュテーブルが使えます。
テストデータ
呼び出し
Sub test()
' Newしたら、初回だけの処理としてあらかじめ辞書情報を仕込ませる。
Dim 社員名で情報 As New Hashtable
Set 社員名で情報 = 社員名で情報.初期設定(ThisWorkbook.FullName, "Sheet1", "C3")
' この例の場合だと、
' 社員名で情報.が欲しい(社員名, 列名)
' と書けば、ハッシュテーブルから情報を取れます。
'----デバッグ用----
Dim Keys() As Variant: ReDim Keys(1, 3)
Keys(0, 0) = "高橋": Keys(1, 0) = "年齢"
Keys(0, 1) = "重田": Keys(1, 1) = "年齢"
Keys(0, 2) = "田中": Keys(1, 2) = "体重"
Keys(0, 3) = "浜中": Keys(1, 3) = "体重"
Dim rslt as Variant
Dim lp As Integer: For lp = 0 To UBound(Keys, 2)
rslt = 社員名で情報.が欲しい(Keys(0, lp), Keys(1, lp))
If IsError(rslt) Then
Select Case rslt
Case CVErr(1): Debug.Print Keys(0, lp) & " という社員は存在していません。"
Case CVErr(2): Debug.Print Keys(1, lp) & " という項目は存在していません。"
Case CVErr(3): Debug.Print Keys(0, lp) & " という社員も " & Keys(1, lp) & " という項目も両方存在していません。"
End Select
Else: Debug.Print Keys(0, lp) & " さんの" & Keys(1, lp) & "は、" & rslt & " です。"
End If
Next lp
End Sub
- 本体のクラス
Public 辞書 As Object
Public 列名 As Object
Public キー列名 As String
'// 0. コンストラクタ(引数)と同等の処理 ～ エクセルを読んで、あらかじめDictionaryに仕込んでおく
' (VBAではコンストラクタに引数を渡せないので、こうするしかなかった)
Property Get Self() As Object
Set Self = Me
End Property
Function 初期設定(読みたいブックのフルパス As String, 読むシート名 As String _
, どのセル番地から右で辞書作りたいの As String) As Hashtable
Dim rWbk As Workbook, rSht As Worksheet, rng As Range, Lrng As Range
Set rWbk = エクセル開くよ(読みたいブックのフルパス)
Set rSht = rWbk.Sheets(読むシート名)
Set rng = rSht.Range(どのセル番地から右で辞書作りたいの)
Set Lrng = rng.CurrentRegion.Item(rng.CurrentRegion.Count)
Dim RSR As Long, RSC As Long, RER As Long, REC As Long
RSR = rng.Row: RSC = rng.Column
RER = Lrng.Row: REC = rng.CurrentRegion.Item(1).End(xlToRight).Column
With New Hashtable
Set .辞書 = CreateObject("Scripting.Dictionary")
Set .列名 = CreateObject("Scripting.Dictionary")
.キー列名 = rSht.Cells(RSR, RSC).Value
Dim lpR As Long: Dim lpC As Long: For lpR = 0 To RER - RSR
If lpR = 0 Then
For lpC = 0 To REC - RSC
.列名.Add rSht.Cells(RSR + lpR, RSC + lpC).Value, lpC + 1
Next lpC
Else
' [複数行×1列] を Range(縦1行).value で配列に入れた場合、1回 transpose したら1次元配列になる。
' [1行×複数列] を Range(横1行).value で配列に入れた場合は、2回 transpose したら1次元配列になる。
arr = rSht.Range(rSht.Cells(RSR + lpR, RSC), rSht.Cells(RSR + lpR, REC)).Value
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
.辞書.Add rSht.Cells(RSR + lpR, RSC).Value, arr
End If
Next lpR
''----デバッグ用----
''辞書の中身を全部見せ
' Dim var As Variant, lp1 As Long, varIdx As Variant
'
' Debug.Print vbCr & "まず列名の辞書から" & vbLf
' For Each var In .列名
' Debug.Print "列名(""" & var & """):", .列名(var)
' Next var
' Debug.Print vbCr & "お次は本体の辞書" & vbLf
' For Each var In .辞書
' For lp1 = 0 To REC - RSC
' Debug.Print "辞書(""" & var & """)(" & lp1 + 1 & "):", .辞書(var)(lp1 + 1)
' Next lp1
' Next var
' Debug.Print vbCr & "いよいよ本番" & vbLf
' For Each var In .辞書
' For Each varIdx In .列名
' Debug.Print "辞書(""" & var & """)(列名(""" & varIdx & """)):", .辞書(var)(.列名(varIdx))
' Next varIdx
' Next var
' Debug.Print
Set 初期設定 = .Self
End With
End Function
'// 2. これが、メインのキモとなる機能
Public Function が欲しい(キー As Variant, 欲しい列名 As Variant) As Variant
Select Case True
Case 辞書.exists(キー) And 列名.exists(欲しい列名): が欲しい = 辞書(キー)(列名(欲しい列名))
Case Not 辞書.exists(キー) And 列名.exists(欲しい列名): が欲しい = CVErr(1)
Case 辞書.exists(キー) And Not 列名.exists(欲しい列名): が欲しい = CVErr(2)
Case Not 辞書.exists(キー) And Not 列名.exists(欲しい列名): が欲しい = CVErr(3)
End Select
End Function
'// 2.1 外から問われたとき、キーの配列を返すようにする
Public Function Keys() As Variant
Keys = 辞書.Keys
End Function
' // 1.1 Excelファイルをオープンさせる関数
'第1引数のみ。フルパスの文字列を渡す。
Private Function エクセル開くよ(ByVal BVstr_FileFullPath As String) As Workbook
Select Case IsFileEditable(BVstr_FileFullPath)
Case -1: '見つからない場合は、このブックのオブジェクトを返す。
MsgBox "ご指定のファイル：" & vbCrLf & " " & BVstr_FileFullPath & vbCrLf _
& "が見つかりません。VBEの初期設定で名前を設定し直して下さい。", vbCritical
Set エクセル開くよ = ThisWorkbook: Exit Function
Case 0: 'ファイルが既に開いているときはそのブックを返す。
Set エクセル開くよ = GetObject(BVstr_FileFullPath)
Case 1: 'ファイルが存在していて、開いていない場合は、開かせてからそのブックオブジェクトを返す。
Set エクセル開くよ = Workbooks.Open(BVstr_FileFullPath)
End Select
End Function
' // 1.2 ファイルが編集可能か調べるユーザー関数
Private Function IsFileEditable(ByVal FilePath As String) As Long
' // 戻り値：Long -1：ファイルなし 0：ファイルは使用中 1：ファイルは使用可能
Dim wb As Workbook
Dim n As Integer
If Len(Dir$(FilePath)) = 0 Then
IsFileEditable = -1
Exit Function
End If
n = FreeFile()
On Error Resume Next
Open FilePath For Binary Lock Read Write As #n
Close #n
IsFileEditable = IIf(Err.Number = 0, 1, 0)
On Error GoTo 0
End Function
昨日の記事を見直していると、Dictionaryオブジェクトを二重に仕込むことで、ハッシュテーブルの実装ができると気が付きました。
そして、今日、できました。
- 苦労した点
行・列で２回ループを回していちいち配列に代入するより
配列 ＝ Range(横1行).value
と書いて、横一列を一気に配列に代入するほうが、明らかに高速です。
だから、最初は素直に
配列 ＝ Range(横1行).value と書いて、「これで、ループを回すのは縦の1回だけで済むじゃん、ヤッター！」と安心していたのでした。
実際には数万件のデータがあるので、ループはできれば回したくなかった。
ところが、それだとエラーが出て、なかなか通らない。
なんか、ただの横一列のデータなのに (1 to 1,1 to 3) 配列のようなものとして代入されていたみたいです。ウォッチ式で中身を見たところ。
Excelで 配列 ＝ Range(横1行).value と書いた場合、
ただの横一列のデータを入れ込んだつもりでも、Excelは勝手に2次元配列を代入していることが判明したのです。
でも、どうしても2次元じゃなくて、1次元の(n)の配列にしたかった。
その難所をクリアするのに苦労しました。そこで助けられたのが以下のページ。
・t-hom’s diary(2018-08-02)
VBA TRANSPOSE関数で一次元データのみの二次元配列を一次元配列に変換する。
EXCELで、
[複数行×1列] を Range(縦1行).value で配列に入れた場合、1回 transpose したら1次元配列になる。
[1行×複数列] を Range(横1行).value で配列に入れた場合は、2回 transpose したら1次元配列にできる。
そんなこと・・・知らなかった・・・・
なかなか知ることのない上級者用の知識を学ぶ機会に恵まれました。
- 実行結果
列構造を変えても、データ増やしてもOK。ちゃんと取れてます。
Dictionaryオブジェクトを使ったので、Dictionary.existsでエラーも簡単に拾えます。
これは、ものすごくありがたい機能です。マスタにないエラーが出て、それを埋めるのが大事な作業なので。
とにかく、これが、欲しかった機能でした。まさに、ドンピシャで。
今まで、なんで実装されてなかったのか不思議なくらいです。
近い将来、Excelにもハッシュテーブル関数が実装される日が来るのかもしれません。
しかし、自作でクラスを組んでおいたほうが、個別に細かい応用を効かせられて、何かとよいのではないかと思います。
とにかく、今回のハッシュテーブルクラスの実装は、非常に大きな成果でした。