LoginSignup
2
1

More than 3 years have passed since last update.

Excelに LEFT (OUTER) JOIN を実装

Last updated at Posted at 2019-10-23

追記。
 まず、これは未熟なコードである、ということを申し述べることにします。
 dictionary は動作が不安定な面があるらしいので、collection で書き直すことにします。
また、日本語名も英語に書き直して、option explicit にします。一生懸命書いたのですが、未熟な点が多々ありました。
 配列に代入すると、速いけれどメモリの使用量を食う、ということを全く考慮していないコードを晒してしまいました。申し訳ございません。
 
 ご叱責をいただきましたら、本文部分は修正、もしくは削除にて対応いたします。遠慮なくおっしゃってください。

先日書いたもの
を応用した結果、Excel に LEFT (OUTER) JOIN を実装できました。
もっと洗練させたら、複雑な条件も付けられて、Filter関数をしのぐものができあがるでしょう(多分)。

・テストデータ
LeftJoin前.png

・呼び出し

実行.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

・実行結果
LeftJoin後.png

2
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
2
1