【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メゾットを用いた方法を使用しました。

docs.microsoft.com

 

docs.microsoft.com

docs.microsoft.com

 

本ブログは個人メモです。 本ブログの内容によって生じた損害等の一切の責任を負いかねますのでご了承ください。 また、本ブログ記載内容の無断転載は禁止させていただきます。