VBSでSQLServerに接続しExcelにデータ出力

#はじめに
VBScriptでSQL Serverに接続しSELECTした後にデータをExcelに出力する方法を調べたのでメモします。
コードや記載にコメントが少ないですが備忘録のような記事です。申し訳ございません。
落ち着いたらコメントを追記していきます。

#SQLServerにテスト用DBおよびテーブル、データを登録

--DB作成
CREATE DATABASE dbTest;

--Table作成
use dbTest;
CREATE TABLE [dbo].[Employee](
	[No] [int] NOT NULL,
	[Name] [nchar](15) NOT NULL,
	[RegDate] [date] NOT NULL,
 CONSTRAINT [PK_Employee] PRIMARY KEY CLUSTERED 
(
	[No] ASC
)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
) ON [PRIMARY]

--作成したTableに100万件テストデータを登録
DECLARE @p_InsertNumber Bigint    -- INSERTする行数
SELECT @p_InsertNumber=1000000;  -- 100万に設定

WITH Base AS
  (
    SELECT
      1 AS n
    UNION ALL
    SELECT 
      n + 1
    FROM
      Base
    WHERE
      n < @p_InsertNumber
  ),
  Nums AS
  (
     SELECT
       Row_Number() OVER(ORDER BY n) AS n
     FROM
       Base
  )
  INSERT INTO Employee 
  SELECT
      n
    , 'test'
    ,  GETDATE()
  FROM
    Nums
  WHERE 
    n <= @p_InsertNumber
OPTION (MaxRecursion 0); -- 再帰クエリの再帰回数の上限をなくす

#VBScriptでSQL Serverに接続しSELECTした後にデータをExcelに出力

Option Explicit

'データベース接続情報を定義(Windows認証)
Const MYPROVIDERE = "Provider=SQLOLEDB;"
Const MYSERVER    = "Data Source=DESKTOP-TEST\SQLEXPRESS;"   'サーバー
Const MYNINSYO    = "Trusted_connection=yes;"                   'Windows認証の場合
Const MYDATABASE  = "Initial Catalog=dbTest;"                   '接続するデータベース名

Dim cn
Dim rs
Dim workbook
Dim excelObj
Dim worksheet
	
on error resume next

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Set excelObj = CreateObject("Excel.Application")

if Err.Number = 0 Then
	'データベース接続
	cn.ConnectionString = MYPROVIDERE & MYSERVER & MYNINSYO & MYDATABASE
	cn.Open
	rs.ActiveConnection = cn
	
	If Err.Number = 0 Then
		'Excelの機能を利用するために必要

		'Excelを非表示
		excelObj.Visible = False
		'Excelブックを新規作成
		Set workbook = excelObj.Workbooks.Add()

		Call SelectTable("Select * from Employee where No < 100;",1, "テスト1")
		Call SelectTable("Select * from Employee1 where No < 10;",2, "テスト2")
		Call SelectTable("Select * from Employee where No < 5;",3, "テスト3")
		If Err.Number <> 0 Then
			Wscript.Echo Err.Description
		Else
			'名前つけて保存
			workbook.SaveAs("C:\Users\Desktop\test.xlsx")
			'ワークブックを閉じる
			workbook.Close
		End If

		Set workbook=Nothing
	Else
		Wscript.Echo Err.Description
	End If

end if
'Excelを閉じる
worksheet.Close
excelObj.Quit
Set excelObj = Nothing
'データベース切断
rs.Close
cn.Close
On Error Goto 0
Wscript.Echo "処理終了"


'データベース接続しSelect実行
Sub SelectTable(sql,cnt, name)
	'Select実行
	rs.Source = sql
	rs.Open
	Call ExcelWrite(cnt, name)
	rs.Close
End Sub

'データをExcelに出力
Sub ExcelWrite(cnt, name)
	Dim i
	Dim j

	'シートを指定(名前Or番号で指定)
	Set worksheet = workbook.Sheets(cnt)
	worksheet.Name = name

	i = 1
	Do Until rs.EOF
	    For j = 0 To rs.Fields.Count - 1
	        If i = 1 Then
	            worksheet.Cells(i, j + 1) = rs.Fields(j).Name
	        End If
	        worksheet.Cells(i + 1, j + 1) = rs(j).Value
	    Next
	    rs.MoveNext
	    i = i + 1
	Loop

End Sub

Excel出力で例外が発生した場合、Excelのタスクが残ってしまうというところがまだ解決していません。。

#Excel VBAでSQL Serverに接続しSELECTした後にデータをExcelに出力
いろいろ検討した結果、Excel VBAでSQL Serverに接続しSELECTした後にデータをシートに出力した方が簡潔ということになりました。
以下にサンプルを載せます。

Option Explicit

' SQL ServerにSELECT文を発行し、レコードセットへ取得し、Excelに書き出す。
Sub SQL_GetRecordSet()
 
    On Error GoTo ErrorProc
 
    Application.ScreenUpdating = False
    Dim DBSrv As String
    Dim DBName As String
    Dim strSQL As String
    Dim strConn As String
    Dim strSheetName As String
 
    '----------------------------------------------------
    ' DBSrvにDBサーバ名、DBNameにデータベース名
    '----------------------------------------------------
    DBSrv = "DESKTOP\SQLEXPRESS"
    'DBSrv = "DBSERVER\SQLEXPRESS,49391" 'ポート指定付
    DBName = "dbTest"
 
    '----------------------------------------------------
    ' 発効するSQLの作成(レコードセットへ取り込むSELECT文)
    '----------------------------------------------------
    strSQL = "SELECT * FROM Employee(NOLOCK)"
 
    '----------------------------------------------------
    ' 接続文字列の指定
    '----------------------------------------------------
    'Windows認証
    strConn = "Provider=SQLOLEDB;Data Source='" & DBSrv & "';Initial Catalog='" & DBName & "';Trusted_Connection=Yes"
    'SQL Server認証
    'strConn = "Provider=SQLOLEDB;Data Source='" & DBSrv & "';Initial Catalog='" & DBName & "';UID=【ユーザ名】;PWD=【パスワード】;"
 
    '書き込み先のシート作成
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    strSheetName = Format(Now, "yyyy年MM月dd日hh時mm分ss秒")
    ActiveSheet.Name = strSheetName
    Worksheets(strSheetName).Cells.NumberFormatLocal = "@"
 
    'Excelに書き出し
    Call WriteExcel(strConn, strSQL, strSheetName)
 
    MsgBox "正常に書き出し完了"
    Exit Sub
 
'エラー処理
ErrorProc:
 
    MsgBox Err.Number & vbCrLf & Err.Description
 
End Sub

Sub WriteExcel(strConn As String, strSQL As String, strSheetName As String)
    Dim i As Long
    Dim j As Long
    Dim rs As Recordset
    
    'オブジェクト生成
    Set rs = New ADODB.Recordset
    'SQLを実行し、読み取り専用でレコードセットへ取得
    rs.Open strSQL, strConn, adOpenForwardOnly, adLockReadOnly, adCmdText

    'レコードセットへ先頭へ
    rs.MoveFirst
 
    'Excelに書き出し
    i = 1
    Do Until rs.EOF
        For j = 0 To rs.Fields.Count - 1
            If i = 1 Then
                Worksheets(strSheetName).Cells(i, j + 1) = rs.Fields(j).Name
            End If
            If IsNull(rs(j).Value) Then
                Worksheets(strSheetName).Cells(i + 1, j + 1) = "NULL"
            Else
                Worksheets(strSheetName).Cells(i + 1, j + 1) = rs(j).Value
            End If
            
        Next
        rs.MoveNext
        i = i + 1
    Loop
 
    'クローズ
    rs.Close
    Set rs = Nothing
End Sub

###参考にしたサイト
http://itdiary.info/microsoft-office/post-1355/