【SQL Server & VBA】VBAからSQL Serverに接続し、クエリ結果をExcelシートに貼付する（ヘッダ付き）

VBAからSQL Serverに接続してクエリ結果を取得します。

Microsoft ActiveX Data Objects (ADO)を使用したDBへのアクセス方法です。

本記事はWindows認証による方法です。

以下の図のように、C2～4セルにサーバ名、データベース名、SQL文を入れて実行すると、6行目以降にクエリ結果が出力されるようにしました。

クエリ結果の取得の他、ヘッダー設定、表の罫線設定も一括して行う処理としています。

f:id:cochineal19:20201119221432p:plain — Excelシートのイメージ

Sub SQL接続()
'---------------------------------------
' 設定
'---------------------------------------
    On Error GoTo ERROR1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim ADO_CN, ADO_RS As Object
    Dim myWB As Workbook, myWS As Worksheet
    Dim SRVNM, DBNM, SQLCD, SQLINF As String
    Dim strow, enrow, encol, i As Long
    
    Set myWB = ThisWorkbook
    Set myWS = myWB.Sheets(ActiveSheet.Name)
    
    Set ADO_CN = CreateObject("ADODB.Connection")
    Set ADO_RS = CreateObject("ADODB.Recordset")
    
    '-- SQLサーバ名、DB名、SQLコード
    SRVNM = myWS.Cells(2, 3)
    DBNM = myWS.Cells(3, 3)
    SQLCD = myWS.Cells(4, 3)
    
    '--出力行
    strow = 7
    
'---------------------------------------
' 接続
'---------------------------------------
    SQLINF = "Provider=SQLOLEDB" & _
             "; Data Source=" & SRVNM & _
             "; Initial catalog=" & DBNM & _
             "; Trusted_Connection=Yes"
             
    ADO_CN.Open SQLINF
        ADO_RS.Open SQLCD, ADO_CN, 1, 1
        
            ADO_RS.movefirst
            
            '-- Sheetにデータがあれば先に削除しておく。
            enrow = myWS.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
            If enrow >= strow - 1 Then Rows(strow - 1 & ":" & enrow).Delete
            
            '--SQLクエリ結果をSheetに貼り付け。
            myWS.Cells(strow, 1).CopyFromRecordset ADO_RS
            
            '--ヘッダを貼り付け。Fieldsは0からなので－1する。
            For i = 1 To ADO_RS.Fields.Count
                myWS.Cells(strow - 1, i) = ADO_RS.Fields(i - 1).Name
            Next i
            
        ADO_RS.Close
    ADO_CN.Close
    
    '--罫線設定
    enrow = myWS.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    encol = myWS.UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    
    With myWS.Range(Cells(strow - 1, 1), Cells(enrow, encol))
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    
    myWS.Range(Cells(strow - 1, 1), Cells(strow - 1, encol)).Interior.Color = RGB(137, 189, 222)
    
    '--開始行にwindowを合わせる
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    myWS.Cells(strow, 1).Select
    
    GoTo END1
    
'---------------------------------------
' 後始末
'---------------------------------------
ERROR1:
    MsgBox Err.Number & ":" & Err.Description
    
END1:
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set myWB = Nothing
    Set myWS = Nothing
    Set ADO_CN = Nothing
    Set ADO_RS = Nothing

End Sub

内部的には
ADO.connectionとrecordsetを使っています。
クエリ結果はcopyfromrecordsetメゾットでExcelの指定シートに貼り付けています。

なお、copyfromrecordsetメゾットではヘッダー情報が付きません。
Fieldsメゾットをループしてヘッダを付け加える処理をしています。

最大行数、最大列数の把握はFindメゾットを用いた方法を使用しました。