Excelで、大量データの高速なvlookup = SQL（ADO）を使ってデータを結合する。

（10/17追記）
編集しました。
どうせSQLなので、複数列をマッチングできるようにしました。
これはvlookupではなかなかできないので、だいぶ有用なのではないでしょうか？

しかし未だ問題があって、検索範囲のキーに重複がある場合、
結果のデータ行が増えてしまいます。
今はエラーを返すようにしていますが、どうしたもんでしょうね。

どうせなら完全外部結合ができてもそれはそれで便利なようにも思います。

（↓元の文章）

ExcelのVlookup、5万行×5万行のVlookupとかになると、
結構待たされて、イライラします。

そこで高速Vlookupです。

こちらの高速vlookupを使うという手もあるのですが、
http://excel-ubara.com/excel3/EXCEL019.html

別解として、
Excelをデータベースと見なして、SQLでJoinするという手を作ってみました。
いくつか障害があったのでやや面倒なことになっていますが、知見として。

     'SQL的なVlookup(高速)
    Public Sub VlookupSQL()
    
    Dim SR As Range, SRad
    Dim Key As Range, Keyad
    Dim Target As Range
    Dim arGetIndex
    Dim strSel_Sum
    Dim Buf1, Buf2, Buf3, Buf4, Mode
    
    'キーの選択
    If Selection.Rows.Count = Rows.Count Or Selection.Columns.Count > 1 Then
        MsgBox "キーは複数列・列全体は不可です。", vbExclamation
        End
    End If
    Set Key = Selection
    
    '検索範囲の設定
    On Error Resume Next
        Set Buf1 = Application.InputBox("検索範囲を選択して下さい。（列全体不可）", "検索範囲", Type:=8)
        If Buf1 Is Nothing Then
            MsgBox "キャンセルしました", vbInformation
            End
        End If
    On Error GoTo 0
    If Buf1.Rows.Count = Rows.Count Or Buf1.Areas.Count > 1 Then
        MsgBox "検索範囲は列全体は不可です。", vbExclamation
        End
    End If
    Set SR = Buf1
    SR.Parent.Select
    
    '取得列数（選択するパターン）
    On Error Resume Next
        Set Buf2 = Application.InputBox("検索範囲の中で、取得する列のセルを選択して下さい。（複数OK）", Type:=8)
        If Buf2 Is Nothing Then
            MsgBox "キャンセルしました", vbInformation
            End
        End If
    On Error GoTo 0
    arGetIndex = Array()
    icnt = 0
    For Each hogearea In Buf2.Areas
        For Each hogecell In hogearea.Rows(1).Cells
            icnt = icnt + 1
            ReDim Preserve arGetIndex(icnt - 1)
            arGetIndex(icnt - 1) = hogecell.Column - SR.Columns(1).Column + 1
        Next
    Next
    
    '出力先の選択
    Key.Parent.Select
    Key(1).Select
    On Error Resume Next
        Set Buf3 = Application.InputBox("出力先セルを選択して下さい。", "検索範囲", Type:=8)
        If Buf3 Is Nothing Then
            MsgBox "キャンセルしました", vbInformation
            End
        End If
    On Error GoTo 0
    Set Target = Key.Offset(, Buf3(1).Column - Key.Column)
    
    '接続方法
    '    Mode = Application.InputBox("接続方法を選択して下さい。1:部分外部,2:完全外部,3:内部", "接続方法", 1)
    '    If Mode = 0 Then
    '        MsgBox "キャンセルしました", vbInformation
    '        End
    '    End If
    
    Application.ScreenUpdating = False
    Set defosheet = ActiveSheet
    
    '２つのデータが別シートに分かれている場合、データ範囲にシート名をつければ参照できる。
    'しかしExcelの仕様で、シート名ありの場合65535行以上ではエラーが起きるため、シート名は付けられない。
    'そのためにデータを１つのシートにまとめて処理する必要がある。
    '新規に計算用シートを作成し、そこに各データを転記する
    With ActiveWorkbook.Sheets.Add(before:=Sheets(1))
        
        .Name = "!!!!dummy!!!!"     '絶対被らない名前
        .Activate
        
        'キー範囲をコピー
        Key.Copy
        .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
        Set Key = .Cells(1, 1).Resize(Key.Rows.Count, Key.Columns.Count)
        
        'キーの順番を設定して、広げる
        Key.Offset(, 1).Formula = "=row()"
        Set Key = Key.Resize(, 2)

        '検索範囲のコピー
        SR.Copy
        .Cells(1, Key.Columns.Count + 1).PasteSpecial Paste:=xlPasteValues
        Set SR = .Cells(1, Key.Columns.Count + 1).Resize(SR.Rows.Count, SR.Columns.Count)
    End With
    
    'データ範囲の文字列
    SRad = "[" & SR.Address(False, False) & "]"
    Keyad = "[" & Key.Address(False, False) & "]"
    
    'DBを開く
    Set CN = CreateObject("ADODB.Connection")
    strfile = ActiveWorkbook.FullName
    CNStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strfile _
    & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
    CN.Open CNStr
    CN.CursorLocation = 3
    
    'キーを検索範囲を紐付けて、セレクトする
    'Orderby指定しないと、勝手に昇順SORTされてしまう。
    '選択文字列
    strSel_Sum = ""
    For i = 0 To UBound(arGetIndex)
        If strSel_Sum = "" Then
            strSel_Sum = "select " & SRad & ".F" & arGetIndex(i)
        Else
            strSel_Sum = strSel_Sum & " , " & SRad & ".F" & arGetIndex(i)
        End If
    Next
    
    Sql = Join(Array(strSel_Sum, "from", Keyad, "left join", SRad, _
                    "on", Keyad & ".F1", "=", SRad & ".F1", _
                    "order by", Keyad & ".F2", "ASC"), " ")
                     
    Set RS = CN.Execute(Sql)
    
    '結果を貼り付ける。部分外部の場合は、結果のレコード数があっていないとダメ。
    If Mode = 0 And RS.RecordCount <> Key.Rows.Count Then
        MsgBox "検索データに重複等があると思われます。中断します", vbInformation
    Else
        Target(1).CopyFromRecordset RS
    End If
    
    'シート削除
    Application.DisplayAlerts = False
        Sheets("!!!!dummy!!!!").Delete
    Application.DisplayAlerts = True
    
    '閉じる
    On Error Resume Next
        RS.Close
        CN.Close
        Set RS = Nothing
        Set CN = Nothing
    On Error GoTo 0
    
    defosheet.Select
    Target(1).Select
    Application.ScreenUpdating = True
    
    End Sub