VBA_SQL-select - note4recurrent @ ウィキ

https://www.excellovers.com/archive/category/VBA

Option Explicit

Sub slect()

   'SQLアクセスのFunction化
   'ワークシート処理をsub化
   Application.ScreenUpdating = False      '画面描画の停止
   
   Call clearSheet                                     'シートのクリア
   Call writeVal(accSQL(1, 1000))              'accSQLで検索した結果をwriteValでシートに転記
   
   Application.ScreenUpdating = True       '画面描画の停止解除

End Sub

---

Function accSQL(ByVal startCD As Long, ByVal endCD As Long) As Variant
'   生徒コードの開始、終了の値を受けてSQLから生徒データをダウンロードする。
   '＝＝＝＝＝＝＝＝＝＝＝＝＝＝DB接続
   Dim db      As ADODB.connection     'アクセス用のオブジェクト宣言
   Dim openFl  As Boolean
   openFl = False                                  'オープンフラグ
   
   'エラー処理の宣言
   On Error GoTo ErrorHandler
   
   If db Is Nothing Then                          'インスタンスが存在しない場合
       Set db = New ADODB.connection     'インスタンス生成
       openFl = True                                 'オープンフラグをTrue
   Else    'オブジェクトが存在する場合
       If db.State = adStateClosed Then    'コネクション状態がクローズの場合
           openFl = True                           'オープンフラグオン
       End If
   End If
   
   If openFl = True Then                   'オープンフラグがオンの場合 DB に接続
       db.Open "Provider=-----;" & _
           "Data Source=DBname;" & _
           "Initial Catalog= tablename;" & _
           "User Id=********;" & _
           "Password=******;"
   '    Call MsgBox("接続されました", vbInformation)
   End If
   
   '＝＝＝＝＝＝＝＝＝＝＝＝＝＝SQL実行
   
   Dim rs   As ADODB.Recordset             'SQLにアクセスするオブジェクト宣言
   Set rs = New ADODB.Recordset            'インスタンス生成
   
   rs.ActiveConnection = db                'dbの接続をrsのActivConnectionにセット
   
   'テストデータ取得SQL文をrsにセット
   rs.Source = "SELECT " & _
               " STUCD,SUTNMPRT,SEX,SCHOOLNM " & _
               "FROM " & _
               " dbo.TM_STUDENT " & _
               " WHERE " & _
               " STUCD between " & startCD & " and " & endCD & "  and" & _
               " SCHOOLNM <>''"
   rs.Open                                 'SQL実行
   If rs.EOF = True Then                   'データが存在ない場合
       Call MsgBox("該当データが存在しません")
   Else                                    'データが存在する場合
       accSQL = rs.GetRows                 'GetRowsメソッドでデータを戻り値に格納)
   End If
   
   '＝＝＝＝＝＝＝＝＝＝＝＝＝＝SQLの後処理
   rs.Close                                'レコードセットクローズ
   Set rs = Nothing                        'rsを破棄
   If Not db Is Nothing Then               'オブジェクトが存在する場合
       'コネクション状態がオープンの場合
       If db.State = adStateOpen Then
           db.Close                        'DBクローズ
       End If
       Set db = Nothing                    'オブジェクト破棄
   End If

Exit Function

'エラーの場合
ErrorHandler:
   Call MsgBox("エラー" & Err.Number & Chr(13) & Err.Description, vbCritical)
End Function

---

Sub writeVal(gotVal As Variant)

'gotVal のデータをセルに転記する
'SQL からダウンロードしたデータは縦と横がエクセルと逆なので、
'そのままでは範囲を指定した一括代入に向かない。
'一括代入後worksheetfuncitonで入れ替えペーストすることもできるが
'列の上限は行の上限を下回るのでデータ数が多いと入りきらない可能性がある。
'ここでは取り込んだデータを仮の配列に入れなおしてから貼り付けている。

   Dim b As Workbook
   Set b = ThisWorkbook
   Dim w As Worksheet
   Set w = b.Worksheets(1)         '貼り付けるシートはここで決まる。
   Dim r As Range
   Dim RowSize, columnSize, i, j As Long
   Dim temp()  As Variant          '縦と横を入れ替えるための仮の配列
   
   columnSize = UBound(gotVal, 1)
   RowSize = UBound(gotVal, 2)
   ReDim temp(RowSize, columnSize) '縦と横を入れ替えるための設定
   
   For i = 0 To UBound(gotVal, 1)
       For j = 0 To UBound(gotVal, 2)
           temp(j, i) = gotVal(i, j)
       Next j
   Next i
   
   RowSize = UBound(temp, 1) + 1
   columnSize = UBound(temp, 2) + 1
       
   Set r = w.Range("A2").Resize(RowSize, columnSize)   '貼り付ける範囲を設定
   
   r.Value = temp                                      'シートに貼り付け

End Sub

---

Sub clearSheet()
'   シートのクリア
'   1行目は残している
'   特定の範囲だけを更新したい場合にはここで範囲を決めること
   Range("A2:XFD1048576").Select
   Selection.ClearContents

End Sub