「思い立ったら即SQL」ユーザーフォームからSQL実行

例えば、「血液型って何種類あるんだよ～」

となった時にピボットテーブルや重複の削除機能を利用するのが普通かと思います。
f:id:ExcelLover:20220326231841p:plain

しかしそんなあなたにSQLでの集計をお勧めしたい！

しかも一々コードを書く必要はありません！
ショートカットキーでフォームを呼び出しSQL文を記入して、
ポチッとボタン一発で思い通りの集計が出来ます！

完成品動作
コード
- ユーザーフォーム
- モジュール
SelStart
SelText
モジュール
まとめ

完成品動作

このように選択範囲に対してSQLを実行することが出来ます。
テーブル範囲は上部のテキストボックスで変更することも可能です。 f:id:ExcelLover:20220326232020g:plain

選択範囲の最上部をヘッダーと見做して一覧表示しています。
一覧をダブルクリックすることでSQL文に差し込むことが出来ます。
f:id:ExcelLover:20220326231917g:plain

コード

ユーザーフォーム

Option Explicit
Private Sub UserForm_Initialize()
    Me.TextBox1.Value = ActiveSheet.Name & "$" & Selection.Address(False, False)
    Me.TextBox2.Value = "select * from [テーブル$]"
    Me.TextBox2.SelStart = 7
    Dim myRng As Range
    For Each myRng In Intersect(Selection, Selection.Cells(1, 1).EntireRow)
        Me.ListBox1.AddItem myRng.Value
    Next
End Sub
Private Sub CommandButton1_Click()
    選択範囲にSQL文を実行 Me.TextBox1.Value, Me.TextBox2.Value
    Unload Me
End Sub

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Me.TextBox2.SelText = Me.ListBox1.Value & ","
End Sub

Private Sub UserForm_Activate()
    Me.TextBox2.SetFocus
End Sub

モジュール

Sub 選択範囲にSQL文を実行(テーブル範囲 As String, SQL文 As String)
    Dim myCon As ADODB.Connection: Set myCon = New ADODB.Connection
    myCon.Provider = "Microsoft.ACE.OLEDB.12.0"
    myCon.Properties("Extended Properties") = "Excel 12.0;IMEX=1"
    myCon.Open ThisWorkbook.FullName
    
    Dim myRS As ADODB.Recordset: Set myRS = New ADODB.Recordset
    Dim mySQL As String: mySQL = SQL文
    mySQL = Replace(mySQL, "[テーブル$]", "[" & テーブル範囲 & "]")
    myRS.Open mySQL, myCon, adOpenStatic

    Dim myVar As Variant
    Dim zレコード件数 As Long: zレコード件数 = CLng(myRS.RecordCount)
    Dim zフィールド列数 As Long: zフィールド列数 = CLng(myRS.Fields.Count)
    If zレコード件数 <= 0 Then
         myVar = Array()
    Else
        ReDim myVar(1 To zレコード件数 + 1, 1 To zフィールド列数)
        Dim i As Long
        Dim n As Long
        For n = 1 To CLng(zフィールド列数)
             myVar(1, n) = myRS.Fields(n - 1).Name
        Next
        For i = 2 To UBound(myVar, 1)
            For n = LBound(myVar, 2) To UBound(myVar, 2)
                 myVar(i, n) = myRS.Fields(n - 1).Value
            Next
            myRS.MoveNext
        Next
    End If
    Dim myWB As Workbook: Set myWB = Workbooks.Add
    myWB.ActiveSheet.Range("A1").Resize(UBound(myVar, 1), UBound(myVar, 2)).Value = myVar

    myWB.Activate
    Set myWB = Nothing
    myRS.Close: Set myRS = Nothing
    myCon.Close: Set myCon = Nothing
End Sub