追記。
まず、これは未熟なコードである、ということを申し述べることにします。
dictionary は動作が不安定な面があるらしいので、collection で書き直すことにします。
また、日本語名も英語に書き直して、option explicit にします。一生懸命書いたのですが、未熟な点が多々ありました。
配列に代入すると、速いけれどメモリの使用量を食う、ということを全く考慮していないコードを晒してしまいました。申し訳ございません。
ご叱責をいただきましたら、本文部分は修正、もしくは削除にて対応いたします。遠慮なくおっしゃってください。
先日書いたもの
を応用した結果、Excel に LEFT (OUTER) JOIN を実装できました。
もっと洗練させたら、複雑な条件も付けられて、Filter関数をしのぐものができあがるでしょう（多分）。
・テストデータ
・呼び出し
実行.bas
Sub LeftOuterJoin実装()
'初期条件
Dim 検索表開始セル As Range: Set 検索表開始セル = Range("B2")
Dim 検索条件がある列名 As String: 検索条件がある列名 = "日付"
Dim マスタのキー列が開始するセル As Range: Set マスタのキー列が開始するセル = Range("H3")
Dim マスタのキー列の名前 As String: 検索をかける列の名前 = "商品ID"
Dim マスタの価格がある列の名前 As String: 単価がある列の名前 = "単価"
Dim 貼り付けセル As Range: Set 貼り付けセル = Range("B13")
Dim 開始日付 As Date: 開始日付 = Range("C9").Value
Dim 終了日付 As Date: 終了日付 = Range("C10").Value
'役者の準備
Dim 検索表列辞書 As Object, マスタ列辞書 As Object
Call 開始セルを指定したらそこから右の行全部入ったDictionaryを作る( _
検索表開始セル, 検索表列辞書)
Dim マスタ As New Hashtable2D
Call マスタ.初期設定(マスタのキー列が開始するセル)
Dim 検索条件開始セル As Range: Set 検索条件開始セル = Range( _
番号からセル番地(検索表開始セル.Row + 1, 検索表列辞書(検索条件がある列名) _
) _
)
Dim 検索する1次元配列 As Variant
検索する1次元配列 = _
表内のその列が開始する最初のセルから表内のその1列全部を1次元配列に格納(検索条件開始セル)
Dim 貼り付け箱() As Variant
Dim 貼り付け箱の行数 As Integer: 貼り付け箱の列数 = 6 - 1
Dim 個数 As Long: 個数 = 0 - 1
Dim 開始列 As Long: 開始列 = 検索条件開始セル.Row
Dim 今の列 As Long: 今の列 = 開始列 - 1
'いよいよ実行
Dim LPvar As Variant: For Each LPvar In 検索する1次元配列
今の列 = 今の列 + 1
If 開始日付 <= LPvar And LPvar <= 終了日付 Then
個数 = 個数 + 1: ReDim Preserve 貼り付け箱(貼り付け箱の列数, 個数)
貼り付け箱(0, 個数) = Cells(今の列, 検索表列辞書("ID")).Value
貼り付け箱(1, 個数) = LPvar
貼り付け箱(2, 個数) = マスタ.辞書を引く(Cells(今の列, 検索表列辞書("商品ID")).Value, "商品名")
貼り付け箱(3, 個数) = Cells(今の列, 検索表列辞書("個数")).Value
貼り付け箱(4, 個数) = マスタ.辞書を引く(Cells(今の列, 検索表列辞書("商品ID")).Value, "単価")
貼り付け箱(5, 個数) = 貼り付け箱(3, 個数) * 貼り付け箱(4, 個数)
End If
Next LPvar
Call キレイな配列を貼り付け(貼り付けセル, 貼り付け箱)
End Sub
・共通ライブラリ
共通ライブラリ.bas
'// 1. セル関連
'// セルのRangeオブジェクトから、セル番地の文字列を返させる(例."C25")
Public Function 番号からセル番地(行番号 As Long, 列番号 As Long) As String
番号からセル番地 = 数字をEXCELの列アルファベットに変換(列番号) & 行番号
End Function
Public Function 数字をEXCELの列アルファベットに変換(iCol As Long) As String
Dim iAlpha As Integer: iAlpha = Int(iCol / 27)
Dim iRemainder As Integer: iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
数字をEXCELの列アルファベットに変換 = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
数字をEXCELの列アルファベットに変換 = 数字をEXCELの列アルファベットに変換 & Chr(iRemainder + 64)
End If
End Function
Public Function そのセルのCurrentRegionの最後のセル(基準セル As Range) As Range
With 基準セル
Set そのセルのCurrentRegionの最後のセル = .CurrentRegion.Item(.CurrentRegion.Count)
End With
End Function
'// 2. 配列関連
' 開始セルを指定したらその行のDictionaryを作る(キー：値, アイテム：列番号)
Public Sub 開始セルを指定したらそこから右の行全部入ったDictionaryを作る(開始セル As Range, 辞書 As Object)
Set 辞書 = CreateObject("Scripting.Dictionary")
Dim その行の1次元配列 As Variant
その行の1次元配列 = 表内セルのそこから右全部を1次元配列に格納(開始セル)
Dim LPvar As Variant: For Each LPvar In その行の1次元配列
'Application.Matchは、-1:検査値以上の最小値, 0:検査値に完全一致する値, 1:検査値以下の最大値
辞書.Add LPvar, 開始セル.Column + Application.Match(LPvar, その行の1次元配列, 0) - 1
Next LPvar
End Sub
' セルのRangeオブジェクトを渡すバージョン
Public Function 表内セルのそこから右全部を1次元配列に格納(表内セル As Range) As Variant
Dim LC As Long: LC = そのセルのCurrentRegionの最後のセル(表内セル).Column
Dim ARR() As Variant: ARR = 表内セル.Resize(, LC - 表内セル.Column + 1).Value
表内セルのそこから右全部を1次元配列に格納 = 一次元配列に整形(ARR)
End Function
Public Function 表内のその列が開始する最初のセルから表内のその1列全部を1次元配列に格納( _
開始セル As Range) As Variant
Dim LR As Long: LR = そのセルのCurrentRegionの最後のセル(開始セル).Row
Dim ARR() As Variant: ARR = 開始セル.Resize(LR - 開始セル.Row + 1).Value
表内のその列が開始する最初のセルから表内のその1列全部を1次元配列に格納 = 一次元配列に整形(ARR)
End Function
' Range(縦1行か横1行).Value で渡す配列の初期値は2次元なので、1次元に転換してやる
Public Function 一次元配列に整形(配列 As Variant) As Variant
Select Case UBound(配列, 2)
Case 1: 一次元配列に整形 = WorksheetFunction.Transpose(配列)
Case Is > 1: 一次元配列に整形 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(配列))
End Select
End Function
Public Sub キレイな配列を貼り付け(貼り付け開始セル As Range, 配列)
配列 = WorksheetFunction.Transpose(配列)
Dim iRowMax: iRowMax = UBound(配列, 1) - LBound(配列, 1) + 1 '// 一次元配列の最大行数
Dim iColMax: iColMax = UBound(配列, 2) - LBound(配列, 2) + 1 '// 二次元配列の最大列数
貼り付け開始セル.Resize(iRowMax, iColMax).Value = 配列 '// 開始セルから貼り付ける
End Sub
Public Function 配列の次元数をゲット(配列 As Variant) As Long
Dim TempData As Variant, i As Long, 次元数 As Long
On Error Resume Next: Do While Err.Number = 0
i = i + 1: TempData = UBound(配列, i)
Loop: On Error GoTo 0
配列の次元数をゲット = i - 1
End Function
・ハッシュテーブルクラス
HastTable2D.cls
Public 辞書 As Object
Public 列名 As Object
Public Sub 初期設定(ByRef 開始セル As Range)
Dim 表の終了セル As Range
Set 表の終了セル = そのセルのCurrentRegionの最後のセル(開始セル)
Dim RSR As Long, RSC As Long, RER As Long, REC As Long
With 開始セル
RSR = .Row: RSC = .Column: RER = 表の終了セル.Row: REC = 表の終了セル.Column
End With
Dim キーに入れたいセルたち As Range, アイテムに入れたいセルたち As Range
Dim lpRng As Range, lpCnt As Long: lpCnt = 1
Dim arrTMP As Variant
Set 辞書 = CreateObject("Scripting.Dictionary")
Set 列名 = CreateObject("Scripting.Dictionary")
Set キーに入れたいセルたち = 開始セル.Resize(, REC - RSC + 1)
For Each lpRng In キーに入れたいセルたち
列名.Add lpRng.Value, lpCnt: lpCnt = lpCnt + 1
Next lpRng
Set アイテムに入れたいセルたち = キーに入れたいセルたち
Set キーに入れたいセルたち = 開始セル.Offset(1).Resize(RER - RSR)
For Each lpRng In キーに入れたいセルたち
Set アイテムに入れたいセルたち = アイテムに入れたいセルたち.Offset(1)
If 配列の次元数をゲット(アイテムに入れたいセルたち.Value) = 2 Then
ARR = 一次元配列に整形(アイテムに入れたいセルたち.Value)
End If
辞書.Add lpRng.Value, ARR
Next lpRng
'----デバッグ用----
'辞書の中身を全部見せて
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 = 1 To REC - RSC + 1
Debug.Print "辞書(""" & var & """)(" & lp1 & "):", 辞書(var)(lp1)
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
End Sub
'// 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
・実行結果
