使い方

[連想配列]

 Dim 表 As Table: Set 表 = New Table
 Call 表.Init(rng) 
 表.gvfkv(キー値, ほしい列名)

　1. TableクラスをNewしてやって、
　2. Call 表.Init(キー開始セル) で見たい表を初期設定してやって、
　3. 表.gvfkv(キー値, ほしい列名) で、値が取れる。

[SQL]

 Call SQL(実行するブック名, 結果を格納するRecordSet, AccessのSQL文)

　で渡してやるだけ。RecordSetは参照渡しで無事解決。

ソース

・呼び出し部

Main.bas

Sub EXEC()
 Call TimeMeasure("test")
End Sub

Sub test()
 Dim wks As Worksheet
 Set wks = SetSheet("ブックのフルパス", "シート名")

 Dim rng As range
 Set rng = wks.range("キー列の開始セル番地")

 Dim 帳票 As Table: Set 帳票 = New Table
 Call 帳票.Init(rng)

 With 帳票
 Debug.Print .gvfkv(63654, "伝票日付")
 Debug.Print .gvfkv(63654, "決済日")
 Debug.Print .gvfkv(63654, "税込金額")
 Debug.Print .gvfkv(63654, "請求書発行済")
 Debug.Print .gvfkv(63654, "消費税改正")
 Debug.Print .gvfkv(66113, "伝票日付")
 Debug.Print .gvfkv(66113, "決済日")
 Debug.Print .gvfkv(66113, "税込金額")
 Debug.Print .gvfkv(66113, "請求書発行済")
 Debug.Print .gvfkv(66113, "消費税改正")
 End With
 'SQL部
 Dim arrResult As Object
 Dim strSQL As String
     strSQL = "SELECT * " _
        & "FROM " & 帳票.qryTBL & " AS A " _
        & "WHERE (A.決済日>=#2019/10/1# AND A.伝票日付<=#2019/9/1#) "

 Call SQL(帳票.strTableBookName, arrResult, strSQL)
 貼り付けたいシート.range(貼り付ける番地).CopyFromRecordset arrResult
 pblc_str_PublicMsg = arrResult.RecordCount & "件ありました。"


'SQLの本体。手続き型でSQLを実装するのは不可能に近い。
Public Sub SQL(ByVal DBwbkName_ As String, ByRef arrResult_ As Object, ByVal strSQL_ As String)
 '集合的にやるのは、やっぱりSQLでしかムリ。自分にADO接続する
    Dim cn As Object, rs As Object, query As String
    Const adOpenKeyset = 1: Const adLockReadOnly = 1
    Set cn = CreateObject("ADODB.Connection")
    Set arrResult_ = CreateObject("ADODB.Recordset")

    cn.Provider = "Microsoft.ACE.OLEDB.12.0"
    'ISAM Formatsの一覧は、ファイル名を実行→regedit で レジストリエディタを出して検索
    'うちの環境では、HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\ClickToRun\REGISTRY\MACHINE\Software\Wow6432Node\Microsoft\Office\16.0\Access\Access Connectivity Engine\ISAM Formats
    ' 1行目は項目名(HDR=YESでヘッダあり、IMEX=0でデータ型自動判定,1で全部文字列、データ型を判定させるのに16文字まで探させる)
    cn.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=YES; IMEX=0; MAXSCANROWS=[1..16]"
    cn.Open DBwbkName_   'SQLを実行する単一ブックに接続
    arrResult_.Open strSQL_, cn, adOpenKeyset, adLockReadOnly

''Range.AutoFilter だと激遅すぎて、実用不可
' With rngTableStart
' .AutoFilter TR("決済日"), ">=2019/10/1"
' .AutoFilter TR("伝票日付"), "<=2019/9/1"
' End With
End Sub

・共通ライブラリ

CommonLib.bas

Public pblc_str_PublicMsg As String    '外に出すしかないメッセージを格納

'// 0. WindowsSystem関連
Sub TimeMeasure(bv_strModuleName As String, Optional arg1 As String = "", Optional arg2 As String = "", _
             Optional arg3 As String = "", Optional arg4 As String = "", Optional arg5 As String = "", _
             Optional arg6 As String = "", Optional arg7 As String = "", Optional arg8 As String = "", _
             Optional arg9 As String = "", Optional arg10 As String = "")

 Dim Start As Single, Finish As Single, TimeSpan As Single, Int_Minuite As Integer
 Application.ScreenUpdating = False
  Start = Timer
  Select Case True
  Case arg10 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10
  Case arg9 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9
  Case arg8 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8
  Case arg7 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4, arg5, arg6, arg7
  Case arg6 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4, arg5, arg6
  Case arg5 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4, arg5
  Case arg4 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3, arg4
  Case arg3 <> "": Application.Run bv_strModuleName, arg1, arg2, arg3
  Case arg2 <> "": Application.Run bv_strModuleName, arg1, arg2
  Case arg1 <> "": Application.Run bv_strModuleName, arg1
  Case arg1 = "": Application.Run bv_strModuleName
  End Select
  Finish = Timer: TimeSpan = Finish - Start: Int_Minuite = Int(TimeSpan / 60)
  Application.ScreenUpdating = True
 Debug.Print (pblc_str_PublicMsg & vbCrLf & vbCrLf & _
    "かかった時間は " & Int_Minuite & " 分 " & TimeSpan - (Int_Minuite * 60) & "秒です")
End Sub

'// 1. Book, Sheet, Range Object関連

Public Function SetRange(ByVal BookPath_ As String, ByVal SheetName_ As String, ByVal RangeAddress_ As String) As range
 Dim wSht As Worksheet: Set wSht = SetSheet(BookPath_, SheetName_)
 Set SetRange = wSht.range(RangeAddress_)
End Function

Public Function SetSheet(ByVal BookPath_ As String, ByVal SheetName_ As String) As Worksheet
 Dim wb As Workbook, wSht As Worksheet
 Set wb = OpenExcel(BookPath_)
 Set SetSheet = wb.Sheets(SheetName_)
End Function

Public Function OpenExcel(ByVal BookPath_ As String) As Workbook
 Select Case IsFileEditable(BookPath_)
 Case -1:
  MsgBox "File：" & BookPath_ & vbCrLf & "doesn't exist.", vbCritical
          Set OpenExcel = ThisWorkbook
 Case 0:  Set OpenExcel = GetObject(BookPath_)
 Case 1:  Set OpenExcel = Workbooks.Open(BookPath_)
 End Select
End Function

'// -1: Not Exist, 0: is Opening, 1: Exist but not opened.
Public Function IsFileEditable(ByVal FilePath As String) As Long
 Dim n As Integer
 If Len(Dir$(FilePath)) = 0 Then IsFileEditable = -1: Exit Function
 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

' Convert column number to alphabet.
Public Function ColNumToAlph(iCol As Long) As String
   Dim iAlpha As Long, iRemainder As Long
   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ColNumToAlph = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ColNumToAlph = ColNumToAlph & Chr(iRemainder + 64)
   End If
End Function

'// 2. Array
' Arr=Range(縦1行か横1行).Value で一気に配列に渡すと、配列の初期値は2次元になる。
' なので、1次元に変換（縦1行のときは1回、横1行のときは2回）
Public Function ConvTo_1ColArr(ARR_ As Variant) As Variant
  Select Case UBound(ARR_, 2)
  Case 1: ConvTo_1ColArr = WorksheetFunction.Transpose(ARR_)
  Case Is > 1: ConvTo_1ColArr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ARR_))
  End Select
End Function

・表クラス

Table.cls

Option Base 1
Option Explicit

Public qryTBL As String
Public strTableBookName As String

Private SR As Long, SC As Long, ER As Long, EC As Long
Private shtTable As Worksheet
Private strTableSheetName As String
Private rngTableStart As range, lKeyColStart As Long
Private KC As Object, TR As Object

Public Function Init(ByVal rngKeyColStart_ As range)
 Set rngTableStart = rngKeyColStart_.CurrentRegion.Item(1)
 Set shtTable = rngKeyColStart_.Worksheet

 strTableBookName = shtTable.Parent.FullName
 strTableSheetName = shtTable.Name

 Dim rngCREnd As range
 Dim lp1 As Long
 Dim TitleRow As Variant, KeyColumn As Variant

 If shtTable.FilterMode Then shtTable.ShowAllData

 With rngTableStart
  Set rngCREnd = .CurrentRegion.Item(.CurrentRegion.Count)

  SR = .Row: SC = .Column
  ER = rngKeyColStart_.End(xlDown).Row: EC = rngCREnd.Column

  '[クエリの書式例] FROM [シート名$A1:G10000] 　で、テーブルの範囲を指定
  qryTBL = "[" & strTableSheetName & "$" & _
               ColNumToAlph(SC) & SR & ":" & ColNumToAlph(EC) & ER & "]"

  'Rangeオブジェクトでループを回すより、配列にブチ込んでループを回したほうが速い
  lKeyColStart = rngKeyColStart_.Column - SC + 1
  KeyColumn = ConvTo_1ColArr(rngKeyColStart_.Offset(1).Resize(ER - SR).Value)
  TitleRow = ConvTo_1ColArr(.Resize(, EC - SC + 1).Value)
 End With

On Error GoTo ErrDuplicate

  Set KC = CreateObject("Scripting.Dictionary")
  For lp1 = 1 To UBound(KeyColumn)
   KC.Add KeyColumn(lp1), lp1
  Next lp1

  Set TR = CreateObject("Scripting.Dictionary")
  For lp1 = 1 To UBound(TitleRow)
   TR.Add TitleRow(lp1), lp1
  Next lp1

'Catch error.
Exit Function
ErrDuplicate:
 Debug.Print KeyColumn(lp1)
End Function

' Get Value from Key Value
Function gvfkv(ByVal SearchKeyValue_ As Variant, ByVal SearchColName_ As String) As Variant
 gvfkv = shtTable.Cells(KC(SearchKeyValue_) + SR, TR(SearchColName_) + SC - 1).Value
End Function

　簡潔に書けました。
　連想配列の機能はSQLでも実現できるけれど、値1個出すだけのためにわざわざクエリ書きたくないわー、ってことで。

　65000件中913件書き出しで1.2秒なら、速度も満足です。Range.AutoFilter でやったら2分くらいかかることを考えれば😤
　C++だったらもっと速いでしょうけど、1.2秒だったらもうVBAで十分。余裕で許容範囲クリアー。(Pythonはまだまだ実運用には使えない、Rangeオブジェクトの細かい処理ができない。pandasオブジェクトが本当に使えない、かつ、遅い。VBAで組んだほうが遥かにパフォーマンスが良い)
　これで、自分が持てるテクニックを最大限に使って高速化できました。複雑なフィルター抽出処理は、絶対SQLでやらせたほうがいいですね。
　あとは、SQL文を吐かせる関数を書けば、完成。

後記

Collectionは数値が入らないからムリ
　-> やっぱりDictionaryを使うしかない。
Rangeオブジェクトには、シート名が含まれていることに初めて気づいた。
　-> Rangeオブジェクトを1個クラスに引っ張るだけで、ものすごく楽になる。.Offset .Resize を使ったら、この1個でほとんど用が足りてしまう。
【高速化テクニック】
　配列に1行・1列のセルの値を代入したいとき、ループを回さずに
array = Range(縦1行か横1行).Value で一気に配列に渡すと、Rangeオブジェクトで For each するより速くなる。
　ただ、そのとき array() の初期値は1から始まる仕様になっているので、Option Baseは 1 にしたほうが書きやすい。
【メモリ対策】
　dictionaryは2個仕込む。1つはフィールド行のみ、１つはキー列のみ。こうすることで、表が何万行になるときでも、メモリの使用量を抑えられる。
　見たいシート.Cells(キー列の辞書(キー値),フィールド行の辞書(ほしいフィールドの名前).Value
　とやれば、Range.Valueよりも高速に値を呼び出せる。
表クラスを作る という発想に初めて到達した。初期値を設定しさえすれば、その他にもいろんな動作を組み込める。超便利。なぜ最初からそうしなかったのか・・・。

Excel で連想配列+SQLを実装

使い方

ソース

後記