SQLServerで試してみます。

MDBでのADOの参照・更新記述とどれだけ違うのでしょう。
この時点では「SQL Server 2014 Express Edition」を利用しています。   このページは当初、「SQL Server 2005」のサンプルとして作成していました。
その後「SQL Server 2008」なども経由して「SQL Server 2014」となっています。




サンプルとしての内容変更やソースコードの記述改善は行ないましたが、「SQL Server」のバージョンに影響されての変更は一切ありません。 今後も、新たなバージョンがリリースされた場合でもご確認はいただけると思います。 また、「Express Edition」は学習等を目的としたもので、マイクロソフトのサイトから無償でダウンロードして利用できます。試用期間の制限もありません。




なお、「認証モード」は「混合モード(SQLServer認証とWindows認証)」として下さい。 作成するマクロなどのアプリケーションからはSQLServer認証で固定されたユーザーID、パスワードを使用しますので、 実在するユーザーのアカウントを借りるなどでは、そのユーザーがパスワード変更したとたんに接続ができなくなってしまうからです。
デフォルトは「Windows認証」であって、基本的にはローカルPCのみでSQLServer自体と クライアントアプリを動かすのみの環境となります。 ネットワーク越しのSQLServerで運用する状態での「Windows認証」では、 SQLServerと同一のドメインにログインしているクライアントでないとアプリケーションが実行できません。



サンプルデータベースの準備
ここでは、「SQL Server」で「MDB」と同様のマクロが機能するのかを確認するために、 「SQL Server」上にサンプルのデータベースを用意して動作確認することにします。 サンプルとなるデータベースやテーブルは、「ダウンロード」のSQLServerテーブル定義ツール」で説明しているものを利用します。 データベース、テーブルの作成まではSQLServerテーブル定義ツール」の説明を参照して下さい。

新しいデータベース
(画像をクリックすると、このページのサンプルがダウンロードできます)

このように部署(MST_BUSYO)、役職(MST_YAKU)、社員(MST_SYAIN)、配属(MST_HAIZOKU)のそれぞれのマスタのテーブル作成までが終わっているものとして、データの投入からを説明します。
テーブル作成までの説明及びその材料についてはSQLServerテーブル定義ツール」をご利用願います。




説明する内容は「初期データの投入」と「配属一覧」というこの4つのテーブルを結合させて出力する一覧をExcelに出力させる部分で、 先にMDBの題材で「ワークシートからデータベースに一括登録」ADOでデータを取得する。」で説明していたことをSQL Serverで行なうものです。

Excelシートから初期データを一括投入する。

Excelシートから初期データを一括投入する

先頭の画像をクリックしてダウンロードされる圧縮ファイルを解凍すると「SQLインポートデータ(SAMPLE).xlsm」が現われます。 これがそのシートの画像ですが、シート構成と内容は「ワークシートからデータベースに一括登録」と全く同じものです。
こちらの「SQLインポートデータ(SAMPLE).xlsm」の方はマクロがSQL Serverに合わせて作成しているのですが、 実行に先立って、SQL Server接続時の認証情報等を変更していただく必要があります。

'***************************************************************************************************
'   SQLServer初期データインポートツール
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Active Data Objects 2.x Library
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 17/01/09(1.0.0)新規作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle = "SQLServer初期データインポート"
'---------------------------------------------------------------------------------------------------
'               ↓↓↓ 実行環境により変更して下さい ↓↓↓
Private Const g_cnsServerName = "OSAMU_INOUE\SQLEXPRESS"            ' Data Source
Private Const g_cnsDBName = "SampleCorp1"                           ' Initial Catalog
Private Const g_cnsUserName = "TEST001"                             ' User ID
Private Const g_cnsPassword = "HogeHoge"                            ' Password
'               ↑↑↑ 実行環境により変更して下さい ↑↑↑
'   ※g_cnsUserNameをブランクにするとWindows認証で動作します
'---------------------------------------------------------------------------------------------------

Module1ソースコードの先頭の上下矢印で囲われた部分の値です。
g_cnsServerName」がサーバー名でこれは作者のローカルPCの環境名なので必ず変更して下さい。 先頭の「Microsoft SQL Server Management Studio」の画像の「オブジェクトエクスプローラ」の一番上の名前になります。
g_cnsDBName」がデフォルトのデータベース名です。サンプルのデータベース名を「SampleCorp1」のままで作成している場合はこのままで構いません。
g_cnsUserName」「g_cnsPassword」は実際にSQL Serverに接続する認証情報に変更して下さい。 ローカルPCのみの環境で、Windows認証で利用される場合はどちらもブランクで構いません。

Excelシートから初期データを一括投入する

マクロの環境変更ができたらマクロ「SQLServer初期データインポート」を実行します。
正常ならば処理はほぼ瞬時に完了すると思います。

Excelシートから初期データを一括投入する

正常に完了した場合はこのようにメッセージが表示されます。 異常がある場合はその旨のメッセージが表示されます。

初期データの投入結果

実際に投入されたデータの状況は「Microsoft SQL Server Management Studio」でこのように見ることができます。

では各マスタデータから「配属一覧」を出力してみましょう。
「配属一覧」シート

これが「SQL配属一覧.xlsm」を開いたところです。
上の「SQLインポートデータ(SAMPLE).xlsm」と同様にソースコードの先頭に接続設定があるので、 マクロの実行に先立って、SQL Server接続時の認証情報等を変更していただく必要があります。

変更ができたらマクロ「GetSqlDataByADO」を実行して下さい。

「配属一覧」シート(処理結果)

問題なければこのように配属一覧が表示されます。

ここからはソースコードを紹介します。まずは「SQLServerテーブル定義ツール」です。
「ダウンロード」のSQLServerテーブル定義ツール」のページではソースコードの紹介は行なっていません。 これは「そのまま利用できる」ということからですが、こちらで紹介することにします。

'***************************************************************************************************
'   テーブル作成Script生成(for SQLServer:2005 or Later)
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Windows Script Host Object Model
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 08/08/17(1.0.0)新規作成
' 17/01/08(1.1.0)プロシージャ分割の最適化、コード整理
'***************************************************************************************************
Option Explicit
Private Const g_cnsSH0 = "設定"
Private Const g_cnsSH1 = "原紙"
Private Const g_cnsFilter = "SQLファイル (*.sql),*.sql"
Private Const g_cnsMaru = "○"
Private Const g_cnsBatsu = "×"
Private Const g_cnsNA = "-"
Private Const g_cnsCOM = ","
'---------------------------------------------------------------------------------------------------
' フィールドタイプテーブル
Private Type g_typFieldType
    TypeName As String                                              ' タイプ名
    NeedSize As Boolean                                             ' サイズ要求
    AsNumeric As Boolean                                            ' 数値タイプ
    NeedValue As Boolean                                            ' 値要求
    UseDecimal As Boolean                                           ' 小数桁有効
    Memo As String                                                  ' メモ
End Type
Private g_tblFieldType() As g_typFieldType                          ' フィールドタイプテーブル
Private g_lngFieldTypeMAX As Long                                   ' テーブルINDEX(項目タイプ)

'***************************************************************************************************
'* 処理名 :MAKE_CreateTableSQL
'* 機能  :テーブル作成Script生成(for SQLServer:2005 or Later)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub MAKE_CreateTableSQL()
    '-----------------------------------------------------------------------------------------------
    Const cnsTitle = "テーブル作成Script生成(for SQLServer:2005 or Later)"
    Dim objSh As Worksheet                                          ' Worksheet
    Dim objFso As FileSystemObject                                  ' Scripting.FileSystemObject
    Dim objTs As TextStream                                         ' TextStream
    Dim objWsh As WshShell                                          ' WshShell
    Dim vntFileName As Variant                                      ' ファイル名(受取)
    Dim strFileName As String                                       ' ファイル名
    Dim strFileName2 As String                                      ' ファイル名(パス無)
    Dim strCurrentPathSV As String                                  ' カレントフォルダ(退避)
    Dim strDataBaseID As String                                     ' データベースID
    Dim strTimeStamp As String                                      ' タイムスタンプ(表示)
    '-----------------------------------------------------------------------------------------------
    ' 項目属性テーブル作成
    Call GP_SetDataTypeTable
    '-----------------------------------------------------------------------------------------------
    ' 登録内容の検査⇒チェックNGは終了
    If Not FP_CheckSheet(strDataBaseID) Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    Set objWsh = New WshShell                                       ' WshShell
    ' 一旦、カレントフォルダを変更
    On Error Resume Next
    strCurrentPathSV = objWsh.CurrentDirectory
    objWsh.CurrentDirectory = ThisWorkbook.Path
    strFileName2 = "CreateTable_" & strDataBaseID & ".sql"
    On Error GoTo 0
    ' スクリプトファイル名の受け取り
    vntFileName = Application.GetSaveAsFilename(strFileName2, g_cnsFilter, , _
                                                "スクリプトの出力ファイル名の指定")
    ' カレントフォルダの復旧
    If strCurrentPathSV <> "" Then
        On Error Resume Next
        objWsh.CurrentDirectory = strCurrentPathSV
        On Error GoTo 0
    End If
    Set objWsh = Nothing
    ' キャンセル確認
    If VarType(vntFileName) = vbBoolean Then Exit Sub
    strFileName = vntFileName
    '-----------------------------------------------------------------------------------------------
    ' 出力ファイルのOPEN
    strTimeStamp = Format(Now(), "MM/DD/YYYY HH:NN:SS")
    Set objFso = New FileSystemObject
    Set objTs = objFso.CreateTextFile(Filename:=strFileName, OverWrite:=True, Unicode:=True)
    ' USE文処理
    With objTs
        .WriteLine "USE [" & strDataBaseID & "]"
        .WriteLine "GO"
        .WriteLine "SET ANSI_NULLS ON"
        .WriteLine "GO"
        .WriteLine "SET QUOTED_IDENTIFIER ON"
        .WriteLine "GO"
    End With
    ' 各テーブルの処理
    For Each objSh In ThisWorkbook.Worksheets
        If ((objSh.Name <> g_cnsSH0) And (objSh.Name <> g_cnsSH1)) Then
            ' テーブルの追加(サブ処理)
            Call GP_ADD_Table(objTs, objSh, strTimeStamp)
        End If
    Next objSh
    objTs.Close
    Set objTs = Nothing
    Set objFso = Nothing
End Sub

'***************************************************************************************************
'  ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_ADD_Table
'* 機能  :テーブルの追加
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = TextStream(Object)
'*      Arg2 = 対象シート(Excel.Worksheet)
'*      Arg3 = タイムスタンプ(表示)(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_ADD_Table(ByRef objTs As TextStream, _
                         ByRef objSh As Worksheet, _
                         ByVal strTimeStamp As String)
    '-----------------------------------------------------------------------------------------------
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngGyoMax As Long                                           ' 行INDEX上限
    Dim lngCol As Long                                              ' カラムINDEX
    Dim strTableID As String                                        ' テーブルID
    Dim tblMaxIndex(6 To 11) As Long                                ' INDEX最大値テーブル
    With objSh
        ' テーブルID
        strTableID = Trim(.Cells(3, 3).Value)
        objTs.WriteLine ""
        objTs.WriteLine "/****** オブジェクト:  Table [dbo].[" & strTableID & _
            "]    スクリプト日付: " & strTimeStamp & " ******/"
        objTs.WriteLine "SET ANSI_PADDING ON"
        objTs.WriteLine "GO"
        objTs.WriteLine "CREATE TABLE [dbo].[" & strTableID & "]("
        ' 各フィールドの追加
        lngGyoMax = .Range("$E$" & .Rows.Count).End(xlUp).Row
        lngGyo = 5
        ' 最終行まで繰り返す
        Do While lngGyo <= lngGyoMax
            ' フィールドの追加
            Call GP_ADD_Field(objTs, objSh, lngGyo, tblMaxIndex)
            ' 次の行へ
            lngGyo = lngGyo + 1
        Loop
    End With
    ' プライマリキーの追加
    If tblMaxIndex(6) <> 0 Then
        Call GP_ADD_PrimaryKey(objTs, objSh, lngGyoMax, tblMaxIndex(6), strTableID)
    End If
    objTs.WriteLine ") ON [PRIMARY]"
    objTs.WriteLine "GO"
    objTs.WriteLine "SET ANSI_PADDING OFF"
    objTs.WriteLine "GO"
    ' インデックスのセット
    For lngCol = 7 To 11
        ' インデックスの指定があるか
        If tblMaxIndex(lngCol) <> 0 Then
            ' インデックスの追加
            Call GP_ADD_Index(objTs, objSh, lngCol, lngGyoMax, tblMaxIndex(lngCol), strTableID)
        End If
    Next lngCol
End Sub

'***************************************************************************************************
'* 処理名 :GP_ADD_Field
'* 機能  :フィールドの追加
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = TextStream(Object)
'*      Arg2 = 対象シート(Excel.Worksheet)
'*      Arg3 = 行INDEX(Long)
'*      Arg4 = INDEX最大値テーブル(Array:Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_ADD_Field(ByRef objTs As TextStream, _
                         ByRef objSh As Worksheet, _
                         ByVal lngGyo As Long, _
                         ByRef tblMaxIndex() As Long)
    '-----------------------------------------------------------------------------------------------
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim strRec As String                                            ' レコードWORK
    Dim strType As String                                           ' フィールドタイプ
    With objSh
        '-----------------------------------------
        ' フィールドIDの指定
        strRec = vbTab & "[" & Trim(.Cells(lngGyo, 5).Value) & "] ["
        ' データ型を設定シートで確認
        strType = Trim(.Cells(lngGyo, 12).Value)
        lngIx = 0
        ' 項目属性テーブルを巡回
        Do While lngIx <= g_lngFieldTypeMAX
            If g_tblFieldType(lngIx).TypeName = strType Then Exit Do
            lngIx = lngIx + 1
        Loop
        ' データ型の指定
        If Right(strType, 5) <> "(MAX)" Then
            strRec = strRec & strType & "]"
        Else
            strRec = strRec & Left(strType, Len(strType) - 5) & "](max)"
        End If
        ' 桁数の指定
        If g_tblFieldType(lngIx).NeedSize Then
            strRec = strRec & "(" & .Cells(lngGyo, 13).Value
            ' 小数桁数の指定
            If g_tblFieldType(lngIx).UseDecimal Then
                strRec = strRec & ", " & Val(.Cells(lngGyo, 15).Value) & ")"
            Else
                strRec = strRec & ")"
            End If
        End If
        ' NULLの指定
        Select Case .Cells(lngGyo, 14).Value
            Case "自動"                         ' 自動インクリメント指定
                strRec = strRec & " IDENTITY(1,1) NOT NULL"
            Case "はい"
                strRec = strRec & " NOT NULL"
            Case "", "いいえ"
                strRec = strRec & " NULL"
        End Select
        strRec = strRec & ","
        objTs.WriteLine strRec
        '-----------------------------------------
        ' プライマリキー,インデックスの確認
        For lngCol = 6 To 11
            If Val(.Cells(lngGyo, lngCol).Value) > tblMaxIndex(lngCol) Then
                tblMaxIndex(lngCol) = Val(.Cells(lngGyo, lngCol).Value)
            End If
        Next lngCol
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_ADD_PrimaryKey
'* 機能  :プライマリキーの追加
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = TextStream(Object)
'*      Arg2 = 対象シート(Excel.Worksheet)
'*      Arg3 = 行INDEX最大値(Long)
'*      Arg4 = INDEX最大値(Long)
'*      Arg5 = テーブルID(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_ADD_PrimaryKey(ByRef objTs As TextStream, _
                              ByRef objSh As Worksheet, _
                              ByVal lngGyoMax As Long, _
                              ByVal lngIxMax As Long, _
                              ByVal strTableID As String)
    '-----------------------------------------------------------------------------------------------
    objTs.WriteLine " CONSTRAINT [PK_" & strTableID & "] PRIMARY KEY CLUSTERED ("
    ' インデックス追加サブ(キーフィールドの指定)
    Call GP_ADD_IndexSUB(objTs, objSh, 6, lngGyoMax, lngIxMax)
    objTs.WriteLine ")WITH (PAD_INDEX  = OFF, STATISTICS_NORECOMPUTE  = OFF," & _
        " IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS  = ON," & _
        " ALLOW_PAGE_LOCKS  = ON) ON [PRIMARY]"
End Sub

'***************************************************************************************************
'* 処理名 :GP_ADD_Index
'* 機能  :インデックスの追加
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = TextStream(Object)
'*      Arg2 = 対象シート(Excel.Worksheet)
'*      Arg3 = カラムINDEX(Long)
'*      Arg3 = 行INDEX最大値(Long)
'*      Arg4 = INDEX最大値(Long)
'*      Arg5 = テーブルID(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_ADD_Index(ByRef objTs As TextStream, _
                         ByRef objSh As Worksheet, _
                         ByVal lngCol As Long, _
                         ByVal lngGyoMax As Long, _
                         ByVal lngIxMax As Long, _
                         ByVal strTableID As String)
    '-----------------------------------------------------------------------------------------------
    Dim idxIX As Long                                               ' INDEX
    idxIX = lngCol - 6
    objTs.WriteLine "CREATE NONCLUSTERED INDEX [IX_" & strTableID & "_" & _
        idxIX & "] ON [dbo].[" & strTableID & "] ("
    ' インデックス追加サブ(キーフィールドの指定)
    Call GP_ADD_IndexSUB(objTs, objSh, lngCol, lngGyoMax, lngIxMax)
    objTs.WriteLine ")WITH (PAD_INDEX  = OFF, STATISTICS_NORECOMPUTE  =" & _
        " OFF, SORT_IN_TEMPDB = OFF, IGNORE_DUP_KEY = OFF," & _
        " DROP_EXISTING = OFF, ONLINE = OFF, ALLOW_ROW_LOCKS  =" & _
        " ON, ALLOW_PAGE_LOCKS  = ON) ON [PRIMARY]"
End Sub

'***************************************************************************************************
'* 処理名 :GP_ADD_IndexSUB
'* 機能  :インデックス追加サブ(キーフィールドの指定)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = TextStream(Object)
'*      Arg2 = 対象シート(Excel.Worksheet)
'*      Arg3 = カラムINDEX(Long)
'*      Arg4 = 行INDEX最大値(Long)
'*      Arg5 = INDEX最大値(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_ADD_IndexSUB(ByRef objTs As TextStream, _
                            ByRef objSh As Worksheet, _
                            ByVal lngCol As Long, _
                            ByVal lngGyoMax As Long, _
                            ByVal lngIxMax As Long)
    '-----------------------------------------------------------------------------------------------
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim tblIndex() As String                                        ' INDEXテーブル
    ReDim tblIndex(1 To lngIxMax)
    With objSh
        lngGyo = 5
        ' 行を巡回
        Do While lngGyo <= lngGyoMax
            ' 設定INDEXのフィールドIDを収集
            If Val(.Cells(lngGyo, lngCol).Value) <> 0 Then
                tblIndex(Val(.Cells(lngGyo, lngCol).Value)) = .Cells(lngGyo, 5).Value
            End If
            lngGyo = lngGyo + 1
        Loop
    End With
    lngIx = 1
    ' インデックスのフィールド情報の出力
    Do While lngIx <= lngIxMax
        If lngIx < lngIxMax Then
            objTs.WriteLine vbTab & "[" & tblIndex(lngIx) & "] ASC,"
        Else
            objTs.WriteLine vbTab & "[" & tblIndex(lngIx) & "] ASC"
        End If
        lngIx = lngIx + 1
    Loop
End Sub

'***************************************************************************************************
'* 処理名 :FP_CheckSheet
'* 機能  :登録内容の検査
'---------------------------------------------------------------------------------------------------
'* 返り値 :チェック成否(Boolean)
'* 引数  :Arg1 = データベースID(String)                          ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_CheckSheet(ByRef strDataBaseID As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Const cnsTitle = "テーブル作成Script生成(処理前チェック)"
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim strMsg As String                                            ' エラーメッセージ
    Dim lngTableIdMAX As Long                                       ' テーブルIDテーブルINDEX
    Dim tblTableID() As String                                      ' テーブルIDテーブル
    lngTableIdMAX = -1
    strMsg = ""
    ReDim tblTableID(0)
    '-----------------------------------------------------------------------------------------------
    If ThisWorkbook.Worksheets.Count <= 2 Then
        MsgBox "テーブル定義が作成されていません。", vbExclamation, cnsTitle
        FP_CheckSheet = False
        Exit Function
    End If
    '-----------------------------------------------------------------------------------------------
    ' ワークシートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' 設定と原紙を除く
        If ((objSh.Name <> g_cnsSH0) And (objSh.Name <> g_cnsSH1)) Then
            ' シート単位チェック
            If FP_CheckSheetSUB(objSh, _
                                strDataBaseID, _
                                lngTableIdMAX, _
                                tblTableID, _
                                strMsg) <> True Then Exit For
        End If
    Next objSh
    '-----------------------------------------------------------------------------------------------
    ' チェック結果
    If strMsg <> "" Then
        MsgBox strMsg, vbExclamation, cnsTitle
        FP_CheckSheet = False
    Else
        FP_CheckSheet = True
    End If
End Function

'***************************************************************************************************
'* 処理名 :FP_CheckSheetSUB
'* 機能  :登録内容の検査(1シート分の内容妥当性チェック)
'---------------------------------------------------------------------------------------------------
'* 返り値 :チェック成否(Boolean)
'* 引数  :Arg1 = チェック対象シート(Excel.Worksheet)
'*      Arg2 = データベースID(String)                          ※Ref参照
'*      Arg3 = テーブルIDテーブルINDEX(Long)
'*      Arg4 = テーブルIDテーブル(Array:String)
'*      Arg5 = エラーメッセージ(String)                        ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_CheckSheetSUB(ByRef objSh As Worksheet, _
                                  ByRef strDataBaseID As String, _
                                  ByRef lngTableIdMAX As Long, _
                                  ByRef tblTableID() As String, _
                                  ByRef strMsg As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strDataBaseID2 As String                                    ' データベースID
    Dim strTableID As String                                        ' 今回テーブルID
    Dim tblFieldId() As String                                      ' フィールドID重複判定テーブル
    Dim lngFieldIdMAX As Long                                       ' フィールドID重複判定MAX
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strAddMsg As String                                         ' メッセージTEMP
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngGyoMax As Long                                           ' データ最終行
    FP_CheckSheetSUB = False
    With objSh
        '-------------------------------------------------------------------------------------------
        strDataBaseID2 = Trim(.Cells(1, 3).Value)                   ' データベースID
        ' 前回登録値確認
        If strDataBaseID <> "" Then
            ' 不一致か
            If strDataBaseID2 <> strDataBaseID Then
                ' 未登録か
                If strDataBaseID2 = "" Then
                    strAddMsg = "「データベースID」が登録されていません。"
                Else
                    strAddMsg = "データベース名「" & strDataBaseID2 & "」が一致していません。"
                End If
                Call GP_CheckSheetError1(strAddMsg, .Name, strMsg)
                Exit Function
            End If
        Else
            strDataBaseID = strDataBaseID2
        End If
        '-------------------------------------------------------------------------------------------
        strTableID = Trim(.Cells(3, 3).Value)                       ' テーブルID
        ' テーブルIDなし
        If strTableID = "" Then
            Call GP_CheckSheetError1("「テーブルID」が登録されていません。", .Name, strMsg)
            Exit Function
        End If
        lngIx = 0
        '-------------------------------------------------------------------------------------------
        ' テーブルIDの重複判定
        Do While lngIx <= lngTableIdMAX
            ' 既に登録されたテーブルIDか
            If tblTableID(lngIx) = strTableID Then
                strAddMsg = "テーブルID「" & strTableID & "」が重複しています。"
                Call GP_CheckSheetError1(strAddMsg, .Name, strMsg)
                Exit Function
            End If
            ' 次へ
            lngIx = lngIx + 1
        Loop
        ' テーブルに追加
        lngTableIdMAX = lngIx
        ReDim Preserve tblTableID(lngTableIdMAX)
        tblTableID(lngTableIdMAX) = strTableID
        '-------------------------------------------------------------------------------------------
        ' 最終行の取得
        If .FilterMode Then .ShowAllData
        lngGyoMax = .Range("$E$" & .Rows.Count).End(xlUp).Row       ' 最終行
        ' 未登録チェック
        If lngGyoMax < 5 Then
            Call GP_CheckSheetError1("フィールド定義がありません。", .Name, strMsg)
            Exit Function
        End If
    End With
    '-----------------------------------------------------------------------------------------------
    lngFieldIdMAX = -1
    ReDim tblFieldId(0)
    ' 各フィールドのチェック
    For lngGyo = 5 To lngGyoMax
        ' 登録内容の検査(1行単位の内容妥当性チェック)
        Call GP_CheckSheetSUB2(objSh, _
                               lngGyo, _
                               lngFieldIdMAX, _
                               tblFieldId, _
                               strMsg)
    Next lngGyo
    '-----------------------------------------------------------------------------------------------
    ' Pri-Key,Indexの重複チェック
    Call GP_CheckSheetSUB3(objSh, lngGyoMax, strMsg)
    ' チェックOK
    FP_CheckSheetSUB = True
End Function

'***************************************************************************************************
'* 処理名 :GP_CheckSheetSUB2
'* 機能  :登録内容の検査(1行単位の内容妥当性チェック)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = チェック対象シート(Excel.Worksheet)
'*      Arg2 = 行INDEX(Long)
'*      Arg3 = フィールドID重複判定テーブル最大INDEX(Long)
'*      Arg4 = フィールドID重複判定テーブル(Array:String)
'*      Arg5 = エラーメッセージ(String)                        ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetSUB2(ByRef objSh As Worksheet, _
                              ByVal lngGyo As Long, _
                              ByRef lngFieldIdMAX As Long, _
                              ByRef tblFieldId() As String, _
                              ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strName As String                                           ' フィールド名
    Dim strType As String                                           ' 項目タイプ
    Dim strAddMsg As String                                         ' メッセージTEMP
    With objSh
        '-------------------------------------------------------
        ' 項目名称
        For lngCol = 2 To 4
            ' カンマが含まれるか
            If InStr(1, .Cells(lngGyo, lngCol).Value, g_cnsCOM, vbTextCompare) <> 0 Then
                strAddMsg = "「項目名称」にカンマは使えません。"
                Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
            End If
        Next lngCol
        '-------------------------------------------------------
        ' フィールドID
        strName = Trim(.Cells(lngGyo, 5).Value)
        ' フィールドID未入力か
        If strName = "" Then
            strAddMsg = "「フィールドID」が未入力です。"
            Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
        Else
            lngIx = 0
            ' テーブルID重複判定テーブルを巡回
            Do While lngIx <= lngFieldIdMAX
                If tblFieldId(lngIx) = strName Then Exit Do
                lngIx = lngIx + 1
            Loop
            ' 重複か
            If lngIx <= lngFieldIdMAX Then
                strAddMsg = "フィールドID「" & strName & "」が重複しています。"
                Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
            Else
                ' テーブルID重複判定テーブルに追加
                lngFieldIdMAX = lngFieldIdMAX + 1
                ReDim Preserve tblFieldId(lngFieldIdMAX)
                tblFieldId(lngFieldIdMAX) = strName
            End If
        End If
        '-------------------------------------------------------
        ' フィールドタイプ(属性)
        strType = Trim(.Cells(lngGyo, 12).Value)
        ' タイプ未入力か
        If strType = "" Then
            strAddMsg = "「属性」が未入力です。"
            Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
        Else
            lngIx = 0
            ' 項目属性テーブルを巡回
            Do While lngIx <= g_lngFieldTypeMAX
                If g_tblFieldType(lngIx).TypeName = strType Then Exit Do
                lngIx = lngIx + 1
            Loop
            ' 属性範囲外
            If lngIx > g_lngFieldTypeMAX Then
                strAddMsg = "「属性」が範囲外の値です。"
                Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
            Else
                If ((.Cells(lngGyo, 6).Value <> 0) And _
                    (.Cells(lngGyo, 14).Value <> "はい") And _
                    (.Cells(lngGyo, 14).Value <> "自動")) Then
                    strAddMsg = "Pri-Key項目は値要求(NOT NULL)が必要です。"
                    Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                End If
                ' サイズ
                If g_tblFieldType(lngIx).NeedSize Then
                    If .Cells(lngGyo, 13).Value = "" Then
                        strAddMsg = "「サイズ」が未入力です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf Not IsNumeric(.Cells(lngGyo, 13).Value) Then
                        strAddMsg = "「サイズ」が数値ではありません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf .Cells(lngGyo, 13).Value < 1 Then
                        strAddMsg = "「サイズ」が範囲外の値です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    End If
                End If
                ' 値要求
                If g_tblFieldType(lngIx).NeedValue Then
                    If ((.Cells(lngGyo, 14).Value = "") Or _
                        (.Cells(lngGyo, 14).Value = g_cnsNA)) Then
                        strAddMsg = "「値要求」が指定されていません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    End If
                End If
                ' 小数桁数
                If g_tblFieldType(lngIx).UseDecimal Then
                    If .Cells(lngGyo, 15).Value = "" Then
                        strAddMsg = "小数桁数が未入力です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf IsNumeric(.Cells(lngGyo, 15).Value) <> True Then
                        strAddMsg = "小数桁数が数値ではありません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf ((.Cells(lngGyo, 15).Value < 0) Or _
                            (.Cells(lngGyo, 15).Value >= .Cells(lngGyo, 13).Value)) Then
                        strAddMsg = "小数桁数が範囲外の値です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    End If
                End If
            End If
        End If
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_CheckSheetSUB3
'* 機能  :登録内容の検査(Pri-Key,Indexの重複チェック)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = チェック対象シート(Excel.Worksheet)
'*      Arg2 = 最終行INDEX(Long)
'*      Arg3 = エラーメッセージ(String)                        ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetSUB3(ByRef objSh As Worksheet, _
                              ByRef lngGyoMax As Long, _
                              ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngIdxMAX As Long                                           ' INDEXテーブル最大INDEX
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngIdxNo As Long                                            ' INDEXナンバー
    Dim strAddMsg As String                                         ' メッセージTEMP
    Dim strKeyName As String                                        ' キーフィールドID(表示)
    Dim vntKeyName As Variant                                       ' キーフィールドIDテーブル
    Dim tblIDX() As Long                                            ' INDEXテーブル
    vntKeyName = Array("Pri-Key", "Index@", "IndexA", "IndexB", "IndexC", "IndexD")
    With objSh
        ' Pri-Key,Index列を巡回
        For lngCol = 6 To 11
            ' Pri-Key,Index列単位処理
            strKeyName = "「" & vntKeyName(lngCol - 6) & "」"
            ' INDEXテーブルを初期化
            lngIdxMAX = -1
            ReDim tblIDX(0)
            ' 登録行を巡回
            For lngGyo = 5 To lngGyoMax
                ' ブランク行を除く
                If .Cells(lngGyo, lngCol).Value <> "" Then
                    ' 非数値か
                    If Not IsNumeric(.Cells(lngGyo, lngCol).Value) Then
                        strAddMsg = strKeyName & "が数字ではありません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf .Cells(lngGyo, lngCol).Value < 0 Then
                        ' マイナス値
                        strAddMsg = strKeyName & "が範囲外の値です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf .Cells(lngGyo, lngCol).Value > 0 Then
                        ' ゼロ以外は重複チェックへ
                        lngIdxNo = .Cells(lngGyo, lngCol).Value
                        ' 新たなINDEXか
                        If lngIdxNo > lngIdxMAX Then
                            ' 要素を追加
                            lngIdxMAX = lngIdxNo
                            ReDim Preserve tblIDX(lngIdxMAX)
                            tblIDX(lngIdxMAX) = lngIdxNo
                        ElseIf tblIDX(lngIdxNo) = 0 Then
                            ' 未使用INDEXは番号をセット
                            tblIDX(lngIdxNo) = lngIdxNo
                        Else
                            ' 重複
                            strAddMsg = strKeyName & "同一レベル番号が重複しています。"
                            Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                        End If
                    End If
                End If
            Next lngGyo
            ' INDEXテーブルが登録されたか
            If lngIdxMAX >= 1 Then
                ' INDEXテーブルを巡回
                For lngIx = 1 To lngIdxMAX
                    If tblIDX(lngIx) = 0 Then
                        strAddMsg = strKeyName & "レベル番号が欠落しています。:" & lngIx
                        Call GP_CheckSheetError1(strAddMsg, .Name, strMsg)
                    End If
                Next lngIx
            End If
        Next lngCol
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_CheckSheetError1
'* 機能  :エラーメッセージ編集@(シート名付加)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 今回エラーメッセージ(String)
'*      Arg2 = シート名(String)
'*      Arg3 = エラーメッセージ累積(String)                    ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月08日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetError1(ByVal strAddMsg As String, _
                                ByVal strSheetName As String, _
                                ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    strAddMsg = strAddMsg & "(シート名:" & strSheetName & ")"
    ' エラーメッセージ累積
    Call GP_AppendMessage(strAddMsg, strMsg)
End Sub

'***************************************************************************************************
'* 処理名 :GP_CheckSheetError2
'* 機能  :エラーメッセージ編集A(シート名、行番号付加)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 今回エラーメッセージ(String)
'*      Arg2 = シート名(String)
'*      Arg3 = 行番号(Long)
'*      Arg4 = エラーメッセージ累積(String)                    ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月08日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetError2(ByVal strAddMsg As String, _
                                ByVal strSheetName As String, _
                                ByVal lngGyo As Long, _
                                ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    Dim strAddMsg2 As String                                        ' メッセージWORK
    strAddMsg2 = lngGyo & "行目、" & strAddMsg & "(シート名:" & strSheetName & ")"
    ' エラーメッセージ累積
    Call GP_AppendMessage(strAddMsg2, strMsg)
End Sub

'***************************************************************************************************
'* 処理名 :GP_SetDataTypeTable
'* 機能  :項目属性テーブル作成
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月08日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_SetDataTypeTable()
    '-----------------------------------------------------------------------------------------------
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngGyo As Long                                              ' 行INGEX
    Dim objSh0 As Worksheet                                         ' 「設定」シート
    Set objSh0 = ThisWorkbook.Worksheets(g_cnsSH0)                  ' 設定
    lngIx = -1
    lngGyo = 2
    ReDim g_tblFieldType(0)
    With objSh0
        If .FilterMode Then .ShowAllData
        ' 登録を巡回
        Do While lngGyo <= .Range("$A$" & .Rows.Count).End(xlUp).Row
            lngIx = lngIx + 1
            ReDim Preserve g_tblFieldType(lngIx)
            g_tblFieldType(lngIx).TypeName = .Cells(lngGyo, 1).Value   ' 表示タイプ
            g_tblFieldType(lngIx).NeedSize = .Cells(lngGyo, 2).Value = g_cnsMaru  ' サイズ要求
            g_tblFieldType(lngIx).AsNumeric = .Cells(lngGyo, 3).Value = g_cnsMaru ' 数値タイプ
            g_tblFieldType(lngIx).NeedValue = .Cells(lngGyo, 4).Value <> g_cnsBatsu ' 値要求
            g_tblFieldType(lngIx).UseDecimal = .Cells(lngGyo, 5).Value = g_cnsMaru ' 小数桁有効
            g_tblFieldType(lngIx).Memo = .Cells(lngGyo, 6).Value      ' メモ
            ' 次の行へ
            lngGyo = lngGyo + 1
        Loop
    End With
    g_lngFieldTypeMAX = lngIx
End Sub

'***************************************************************************************************
'  ■■■ 共通サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_StopScreen
'* 機能  :画面描画停止
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = ガイドメッセージ(String)            ※Option
'*      Arg2 = マウスカーソル制御(Boolean)         ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StopScreen(Optional ByVal strGUIDE As String = "", _
                          Optional ByVal swWait As Boolean = False)
    '-----------------------------------------------------------------------------------------------
    With Application
        .ScreenUpdating = False                         ' 画面描画停止
        .Calculation = xlCalculationManual              ' 自動計算停止
        If strGUIDE <> "" Then .StatusBar = strGUIDE    ' ステータスバー
        If swWait <> True Then .Cursor = xlWait         ' マウスカーソル(砂時計)
        .EnableEvents = False                           ' イベントを抑制
'        .EnableCancelKey = xlDisabled                   ' Escキー無効
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_StartScreen
'* 機能  :画面描画再開
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = ガイドメッセージ(String)            ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StartScreen(Optional ByVal strGUIDE As String = "")
    '-----------------------------------------------------------------------------------------------
    With Application
'        .EnableCancelKey = xlInterrupt                  ' Escキー無効解除
        If .Calculation <> xlCalculationAutomatic Then
            .Calculation = xlCalculationAutomatic       ' 自動計算開始
        End If
        .Cursor = xlDefault                             ' マウスカーソル(標準)
        If strGUIDE <> "" Then
            .StatusBar = strGUIDE                       ' ステータスバー
        Else
            .StatusBar = False
        End If
        .EnableEvents = True                            ' イベント抑制解除
        .ScreenUpdating = True                          ' 画面描画復旧
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_AppendMessage
'* 機能  :エラーメッセージ累積
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 今回追加メッセージ(String)
'*      Arg2 = 表示用累積メッセージ(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月08日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:改行を加えながらメッセージを追加する
'* 注意事項:
'***************************************************************************************************
Private Sub GP_AppendMessage(ByRef strAddMsg As String, ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    If strMsg <> "" Then strMsg = strMsg & vbCrLf
    strMsg = strMsg & strAddMsg
End Sub

'------------------------------------------<< End of Source >>--------------------------------------
この処理はシート上に登録された内容に従ってテーブルを作成するスクリプトを出力するもので、直接SQL Serverのテーブルを作成するわけではありません。 従って、SQL Serverへの認証の問題などもないわけです。
ソースコードは大変長い(900行以上)ですが、半分以上はシート上の内容チェックに費やされています。

次は「SQLインポートデータ(SAMPLE).xlsm」です。

'***************************************************************************************************
'   SQLServer初期データインポートツール
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Active Data Objects 2.x Library
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 17/01/09(1.0.0)新規作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle = "SQLServer初期データインポート"
'---------------------------------------------------------------------------------------------------
'               ↓↓↓ 実行環境により変更して下さい ↓↓↓
Private Const g_cnsServerName = "OSAMU_INOUE\SQLEXPRESS"            ' Data Source
Private Const g_cnsDBName = "SampleCorp1"                           ' Initial Catalog
Private Const g_cnsUserName = "TEST001"                             ' User ID
Private Const g_cnsPassword = "HogeHoge"                            ' Password
'               ↑↑↑ 実行環境により変更して下さい ↑↑↑
'   ※g_cnsUserNameをブランクにするとWindows認証で動作します
'---------------------------------------------------------------------------------------------------
Private Const g_cnsSH1 = "原紙"
Private Const g_cnsADO_SQL_CONNECT1 = "Provider=SQLOLEDB;Data Source="
Private Const g_cnsADO_SQL_CONNECT2 = "Initial Catalog="
Private Const g_cnsADO_SQL_CONNECT3 = "User ID="
Private Const g_cnsADO_SQL_CONNECT4 = "Password="
Private Const g_cnsADO_SQL_CONNECT5 = "Trusted_connection=yes;"

'***************************************************************************************************
'* 処理名 :SQLServer初期データインポート
'* 機能  :SQLServerへ初期データインポートを行なう
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:スキーマはdbo固定となっています
'***************************************************************************************************
Public Sub SQLServer初期データインポート()
    '-----------------------------------------------------------------------------------------------
    Dim dbCon As ADODB.Connection                                   ' ADODB.Connection
    Dim dbCmd As ADODB.Command                                      ' ADODB.Command
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim blnSuccess As Boolean                                       ' 処理成否
    '-----------------------------------------------------------------------------------------------
    blnSuccess = False
    ' SQLServerに接続
    If Not FP_ConnectSQL(dbCon) Then Exit Sub
    ' コマンドを生成
    Set dbCmd = New ADODB.Command
    dbCmd.ActiveConnection = dbCon
    '-----------------------------------------------------------------------------------------------
    ' 本ブックのワークシートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' 「原紙」シートは除外
        If objSh.Name <> g_cnsSH1 Then
            ' ワークシート単位処理
            blnSuccess = FP_WorksheetProc(dbCon, dbCmd, objSh)
            ' 不成功は終了
            If Not blnSuccess Then Exit For
        End If
    Next objSh
    Application.StatusBar = False
    ' MDBを切断
    dbCon.Close
    Set dbCmd = Nothing
    Set dbCon = Nothing
    ' 成功?
    If blnSuccess Then
        MsgBox "初期データインポートは成功しました。", vbInformation, g_cnsTitle
    End If
End Sub

'***************************************************************************************************
'* 処理名 :FP_WorksheetProc
'* 機能  :ワークシート単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数  :Arg1 = ADODB.Connection(Object)
'*      Arg2 = ADODB.Command(Object)
'*      Arg3 = Excel.Worksheet(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:1つのテーブルに対する初期データの投入
'* 注意事項:先頭でDELETE文を発行しているので以前のデータは全て削除されます
'***************************************************************************************************
Private Function FP_WorksheetProc(ByRef dbCon As ADODB.Connection, _
                                  ByRef dbCmd As ADODB.Command, _
                                  ByRef objSh As Worksheet) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngEndRow As Long                                           ' 行INDEX上限
    Dim lngEndCol As Long                                           ' カラムINDEX上限
    Dim strSQL_Base As String                                       ' SQL文共通部
    Dim strSQL As String                                            ' SQL文
    Dim strMSG As String                                            ' メッセージ
    With objSh
        '-------------------------------------------------------------------------------------------
        Application.StatusBar = .Name & " インポート中...."
        ' 最終行、最終列の取得
        If .FilterMode Then .ShowAllData
        lngEndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lngEndCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' データ無しは無視
        If ((lngEndRow <= 2) Or (lngEndCol < 1)) Then
            FP_WorksheetProc = True
            Exit Function
        End If
        '-------------------------------------------------------------------------------------------
        ' Transaction開始
        dbCon.BeginTrans
        '-------------------------------------------------------------------------------------------
        ' TRUNCATE文発行
        strSQL = "TRUNCATE TABLE " & FP_EditTableName(.Name) & ";"
        dbCmd.CommandText = strSQL
        dbCmd.Execute
        '-------------------------------------------------------------------------------------------
        ' INSERT文共通部の編集(シート名をテーブルID、1行目の値をフィールドIDとして編集)
        strSQL_Base = "INSERT INTO " & FP_EditTableName(.Name) & _
            " (" & FP_EditFieldName(.Cells(1, 1).Value)
        lngCol = 2
        ' 全列を編集
        Do While lngCol <= lngEndCol
            ' フィールド名の編集(共通関数の呼び出し)
            strSQL_Base = strSQL_Base & "," & FP_EditFieldName(.Cells(1, lngCol).Value)
            ' 次の列へ
            lngCol = lngCol + 1
        Loop
        strSQL_Base = strSQL_Base & ") VALUES ("
        On Error GoTo FP_WorksheetProc_ERROR
        ' データの先頭は3行目
        lngRow = 3
        '-------------------------------------------------------------------------------------------
        ' 全行を巡回
        Do While lngRow <= lngEndRow
            ' 先頭項目のフィールド値の編集(共通関数の呼び出し)
            strSQL = strSQL_Base & FP_EditFieldValue(.Cells(lngRow, 1), .Cells(2, 1).Value)
            lngCol = 2
            ' カラムを巡回
            Do While lngCol <= lngEndCol
                ' フィールド値の編集(共通関数の呼び出し)
                strSQL = strSQL & "," & _
                    FP_EditFieldValue(.Cells(lngRow, lngCol), .Cells(2, lngCol).Value)
                ' 次の列へ
                lngCol = lngCol + 1
            Loop
            strSQL = strSQL & ");"
            ' コマンドを発行
            dbCmd.CommandText = strSQL
            dbCmd.Execute
            ' 次の行へ
            lngRow = lngRow + 1
        Loop
        '-------------------------------------------------------------------------------------------
        ' コミット
        dbCon.CommitTrans
        FP_WorksheetProc = True
        On Error GoTo 0
    End With
    Exit Function

'===================================================================================================
' 処理失敗対応
FP_WorksheetProc_ERROR:
    strMSG = "MDBへの更新に失敗しました。" & vbCrLf & Err.Description & vbCrLf & strSQL
    MsgBox strMSG, vbCritical, g_cnsTitle
    ' ロールバック
    On Error Resume Next
    dbCon.RollbackTrans
    FP_WorksheetProc = False
    On Error GoTo 0
End Function

'***************************************************************************************************
' ■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :FP_ConnectSQL
'* 機能  :SQLServerへの接続
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数  :Arg1 = ADODB.Connection(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_ConnectSQL(ByRef dbCon As ADODB.Connection) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strMSG As String                                            ' メッセージ
    Dim strConnectString As String                                  ' 接続文字列
    Application.StatusBar = g_cnsServerName & " 接続中...."
    ' 接続文字列の編集
    strConnectString = g_cnsADO_SQL_CONNECT1 & g_cnsServerName & ";"
    strConnectString = strConnectString & g_cnsADO_SQL_CONNECT2 & g_cnsDBName & ";"
    ' UserIDがあるか
    If g_cnsUserName <> "" Then
        ' SQLServer認証
        strConnectString = strConnectString & g_cnsADO_SQL_CONNECT3 & g_cnsUserName & ";"
        strConnectString = strConnectString & g_cnsADO_SQL_CONNECT4 & g_cnsPassword & ";"
    Else
        ' Windows認証
        strConnectString = strConnectString & g_cnsADO_SQL_CONNECT5
    End If
    On Error Resume Next
    Set dbCon = New ADODB.Connection
    ' 接続を確立する
    dbCon.Open strConnectString
    ' 接続確認
    If Err.Number <> 0 Then
        strMSG = "SQLServerへの接続に失敗しました。" & vbCrLf & Err.Description
        MsgBox strMSG, vbCritical, g_cnsTitle
        FP_ConnectSQL = False
    Else
        FP_ConnectSQL = True
    End If
    Application.StatusBar = False
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名 :FP_EditTableName
'* 機能  :テーブル名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数  :Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:DB名接続及びTrim及び鍵カッコで囲う
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditTableName(ByVal strField As String) As String
    '-----------------------------------------------------------------------------------------------
    FP_EditTableName = "[" & g_cnsDBName & "].[dbo].[" & Trim(strField) & "]"
End Function

'***************************************************************************************************
'* 処理名 :FP_EditFieldName
'* 機能  :フィールド名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数  :Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:Trim及び鍵カッコで囲う
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditFieldName(ByVal strField As String) As String
    '-----------------------------------------------------------------------------------------------
    FP_EditFieldName = "[" & Trim(strField) & "]"
End Function

'***************************************************************************************************
'* 処理名 :FP_EditFieldValue
'* 機能  :フィールド値の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数  :Arg1 = 対象セル(Range)
'*      Arg2 = 項目タイプ(Integer)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditFieldValue(ByRef objR As Range, ByVal intType As Integer) As String
    '-----------------------------------------------------------------------------------------------
    Select Case intType
        Case 0                              ' 文字列
            FP_EditFieldValue = "'" & Trim(objR.Value) & "'"
        Case 1                              ' 整数
            FP_EditFieldValue = "'" & CStr(CLng(objR.Value)) & "'"
        Case 2                              ' 実数
            FP_EditFieldValue = "'" & CStr(CCur(objR.Value)) & "'"
        Case 3                              ' BOOL
            FP_EditFieldValue = "'" & CStr(objR.Value = True) & "'"
        Case 4                              ' 日付
            If objR.Value <> "" Then
                FP_EditFieldValue = "'" & Format(objR.Value, "yyyy-MM-dd") & "'"
            Else
                FP_EditFieldValue = "NULL"
            End If
        Case 5                              ' 時刻
            If objR.Value <> "" Then
                FP_EditFieldValue = "'" & Format(objR.Value, "yyyy-MM-dd HH:mm:ss") & "'"
            Else
                FP_EditFieldValue = "NULL"
            End If
        Case Else                           ' 文章
            FP_EditFieldValue = "'" & Replace(Trim(objR.Value), "'", "''") & "'"
    End Select
End Function

'------------------------------------------<< End of Source >>--------------------------------------

最後は「SQL配属一覧.xlsm」です。

'***************************************************************************************************
'   ADOでSQLServerデータベースからデータをシート上に展開する
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Active Data Object 2.x Library(2.8 or Later)
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 17/01/09(1.0.0)新規作成
'***************************************************************************************************
Option Explicit
Private Const g_cnsTitle = "ADOによるSQLServerデータ取得"
'---------------------------------------------------------------------------------------------------
'               ↓↓↓ 実行環境により変更して下さい ↓↓↓
Private Const g_cnsServerName = "OSAMU_INOUE\SQLEXPRESS"            ' Data Source
Private Const g_cnsDBName = "SampleCorp1"                           ' Initial Catalog
Private Const g_cnsUserName = "TEST001"                             ' User ID
Private Const g_cnsPassword = "HogeHoge"                            ' Password
'               ↑↑↑ 実行環境により変更して下さい ↑↑↑
'   ※g_cnsUserNameをブランクにするとWindows認証で動作します
'---------------------------------------------------------------------------------------------------
Private Const g_cnsSH1 = "原紙"
Private Const g_cnsADO_SQL_CONNECT1 = "Provider=SQLOLEDB;Data Source="
Private Const g_cnsADO_SQL_CONNECT2 = "Initial Catalog="
Private Const g_cnsADO_SQL_CONNECT3 = "User ID="
Private Const g_cnsADO_SQL_CONNECT4 = "Password="
Private Const g_cnsADO_SQL_CONNECT5 = "Trusted_connection=yes;"

'***************************************************************************************************
'   ■■■ ADOによるデータ取得 ■■■
'***************************************************************************************************
'* 処理名 :GetSqlDataByADO
'* 機能  :ADOによるデータ取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub GetSqlDataByADO()
    '-----------------------------------------------------------------------------------------------
    Dim dbCon As ADODB.Connection                                   ' ADODB.Connection
    Dim dbRes As ADODB.Recordset                                    ' ADODB.Recordset
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim strSQL As String                                            ' SQL文編集WORK
    Dim strToday As String                                          ' SQL文本日編集WORK
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' 列INDEX
    '-----------------------------------------------------------------------------------------------
    ' SQLServerに接続
    If Not FP_ConnectSQL(dbCon) Then Exit Sub
    ' クライアントカーソル設定(adUseServerがデフォルト)
    dbCon.CursorLocation = adUseClient
    On Error GoTo GetSqlDataByADO_ERROR
    '-----------------------------------------------------------------------------------------------
    ' 参照SQL文の編集
    strToday = "'" & Format(Date, "yyyy-MM-dd") & "'"
    strSQL = "SELECT H.[BUSYO_CD]"                                  ' (00)部署コード
    strSQL = strSQL & ",B.[BUSYO_NM]"                               ' (01)部署名
    strSQL = strSQL & ",H.[YAKU_CD]"                                ' (02)役職コード
    strSQL = strSQL & ",Y.[YAKU_NM]"                                ' (03)役職名
    strSQL = strSQL & ",H.[SCD]"                                    ' (04)社員コード
    strSQL = strSQL & ",S.[KANJI_SEI]+S.[KANJI_MEI]"                ' (05)氏名(漢字)
    strSQL = strSQL & ",S.[KANA_SEI]+S.[KANA_MEI]"                  ' (06)氏名(カナ)
    strSQL = strSQL & ",S.[NYUSYA_YMD]"                             ' (07)入社日
    strSQL = strSQL & ",S.[TAISYOKU_YMD]"                           ' (08)退職日
    strSQL = strSQL & " FROM " & FP_EditTableName("MST_HAIZOKU") & " AS H"
    strSQL = strSQL & " INNER JOIN " & FP_EditTableName("MST_SYAIN") & " AS S"
    strSQL = strSQL & " ON (H.[SCD]=S.[SCD])"
    strSQL = strSQL & " LEFT OUTER JOIN " & FP_EditTableName("MST_BUSYO") & " AS B"
    strSQL = strSQL & " ON (H.[BUSYO_CD]=B.[BUSYO_CD])"
    strSQL = strSQL & " LEFT OUTER JOIN " & FP_EditTableName("MST_YAKU") & " AS Y"
    strSQL = strSQL & " ON (H.[YAKU_CD]=Y.[YAKU_CD])"
    strSQL = strSQL & " WHERE S.[NYUSYA_YMD]<=" & strToday
    strSQL = strSQL & " AND (S.[TAISYOKU_YMD] IS NULL OR S.[TAISYOKU_YMD]>" & strToday & ")"
    strSQL = strSQL & " ORDER BY H.[BUSYO_CD],H.[YAKU_CD],H.[SCD];"
    ' 参照SQL文の発行
    Set dbRes = New ADODB.Recordset
    dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly
    ' 画面描画更新停止
    Call GP_StopScreen
    '-----------------------------------------------------------------------------------------------
    ' シート初期化
    Set objSh = ThisWorkbook.Worksheets(1)
    With objSh
        If .FilterMode Then .ShowAllData
        .Rows("2:" & .Rows.Count).ClearContents
        lngRow = 1
        ' 先頭レコードからEOFまで繰り返す
        Do Until dbRes.EOF
            ' 行を加算
            lngRow = lngRow + 1
            ' 全列をシートに展開
            For lngCol = 0 To 8
                .Cells(lngRow, lngCol + 1).Value = dbRes.Fields(lngCol).Value
            Next lngCol
            ' 次のレコードに移る
            dbRes.MoveNext
        Loop
    End With
    GoTo GetSqlDataByADO_EXIT

'===================================================================================================
' 処理失敗対応
GetSqlDataByADO_ERROR:
    Dim strMSG As String                                            ' メッセージ
    strMSG = "データベースの参照に失敗しました。" & vbCrLf & Err.Description & vbCrLf & strSQL
    MsgBox strMSG, vbCritical, g_cnsTitle

'===================================================================================================
' 終了
GetSqlDataByADO_EXIT:
    ' レコードセット、データベースを閉じる
    On Error Resume Next
    dbRes.Close
    Set dbRes = Nothing
    dbCon.Close
    Set dbCon = Nothing
    On Error GoTo 0
    ' 画面描画更新復帰
    Call GP_StartScreen
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
' ■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :FP_ConnectSQL
'* 機能  :SQLServerへの接続
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数  :Arg1 = ADODB.Connection(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_ConnectSQL(ByRef dbCon As ADODB.Connection) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strMSG As String                                            ' メッセージ
    Dim strConnectString As String                                  ' 接続文字列
    Application.StatusBar = g_cnsServerName & " 接続中...."
    ' 接続文字列の編集
    strConnectString = g_cnsADO_SQL_CONNECT1 & g_cnsServerName & ";"
    strConnectString = strConnectString & g_cnsADO_SQL_CONNECT2 & g_cnsDBName & ";"
    ' UserIDがあるか
    If g_cnsUserName <> "" Then
        ' SQLServer認証
        strConnectString = strConnectString & g_cnsADO_SQL_CONNECT3 & g_cnsUserName & ";"
        strConnectString = strConnectString & g_cnsADO_SQL_CONNECT4 & g_cnsPassword & ";"
    Else
        ' Windows認証
        strConnectString = strConnectString & g_cnsADO_SQL_CONNECT5
    End If
    On Error Resume Next
    Set dbCon = New ADODB.Connection
    ' 接続を確立する
    dbCon.Open strConnectString
    ' 接続確認
    If Err.Number <> 0 Then
        strMSG = "SQLServerへの接続に失敗しました。" & vbCrLf & Err.Description
        MsgBox strMSG, vbCritical, g_cnsTitle
        FP_ConnectSQL = False
    Else
        FP_ConnectSQL = True
    End If
    Application.StatusBar = False
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名 :FP_EditTableName
'* 機能  :テーブル名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数  :Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年01月09日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:DB名接続及びTrim及び鍵カッコで囲う
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditTableName(ByVal strField As String) As String
    '-----------------------------------------------------------------------------------------------
    FP_EditTableName = "[" & g_cnsDBName & "].[dbo].[" & Trim(strField) & "]"
End Function

'***************************************************************************************************
'* 処理名 :GP_StopScreen
'* 機能  :画面描画停止
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = ガイドメッセージ(String)            ※Option
'*      Arg2 = マウスカーソル制御(Boolean)         ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StopScreen(Optional ByVal strGUIDE As String = "", _
                          Optional ByVal swWait As Boolean = False)
    '-----------------------------------------------------------------------------------------------
    With Application
        .ScreenUpdating = False                         ' 画面描画停止
        .Calculation = xlCalculationManual              ' 自動計算停止
        If strGUIDE <> "" Then .StatusBar = strGUIDE    ' ステータスバー
        If swWait <> True Then .Cursor = xlWait         ' マウスカーソル(砂時計)
        .EnableEvents = False                           ' イベントを抑制
'        .EnableCancelKey = xlDisabled                   ' Escキー無効
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_StartScreen
'* 機能  :画面描画再開
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = ガイドメッセージ(String)            ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2008年08月17日
'* 作成者 :井上 治
'* 更新日 :2017年01月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StartScreen(Optional ByVal strGUIDE As String = "")
    '-----------------------------------------------------------------------------------------------
    With Application
'        .EnableCancelKey = xlInterrupt                  ' Escキー無効解除
        If .Calculation <> xlCalculationAutomatic Then
            .Calculation = xlCalculationAutomatic       ' 自動計算開始
        End If
        .Cursor = xlDefault                             ' マウスカーソル(標準)
        If strGUIDE <> "" Then
            .StatusBar = strGUIDE                       ' ステータスバー
        Else
            .StatusBar = False
        End If
        .EnableEvents = True                            ' イベント抑制解除
        .ScreenUpdating = True                          ' 画面描画復旧
    End With
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

共通サブ処理を除くと、以前のソースコードに比べて比較的簡単です。
ですが、これはSQL文の方で4つのテーブルを結合させて単純読み取り処理ができるようにしているからです。
部署や役職は、その変異のタイミングで新しいコードに対する名称を取り出せば良いのですが、それをコード化すると3層ブレークの記述になるし、 現在のSQLServerの処理能力からするとそのような記述配慮をしても結果に結びつかないようです。




それよりも、この記述で結構重要なのは、SQLServerへの接続の直後にある

    ' クライアントカーソル設定(adUseServerがデフォルト)
    dbCon.CursorLocation = adUseClient
この一行です。
どういうわけか、ADOの接続は「サーバーカーソル」がデフォルトになっていて、 SQLServerでは非推奨であるばかりではなく、ネットワーク越しのサーバ接続だとレスポンスに影響します。
このサンプル程度のデータ件数であったり、ローカルPCのみでSQLServer自体を動かしていると判らないかも知れませんが、 ネットワーク上から数千件のデータを取得するのに数秒掛かっていたものが、この一行を追加すると一瞬に変わるくらいの影響が出る場合があります。




ここで実行されたSQL文を抜き出して編集すると、


SELECT H.[BUSYO_CD]
      ,B.[BUSYO_NM]
      ,H.[YAKU_CD]
      ,Y.[YAKU_NM]
      ,H.[SCD]
      ,S.[KANJI_SEI]+S.[KANJI_MEI]
      ,S.[KANA_SEI]+S.[KANA_MEI]
      ,S.[NYUSYA_YMD]
      ,S.[TAISYOKU_YMD]
FROM [SampleCorp1].[dbo].[MST_HAIZOKU] AS H
INNER JOIN [SampleCorp1].[dbo].[MST_SYAIN] AS S ON (H.[SCD]=S.[SCD])
LEFT OUTER JOIN [SampleCorp1].[dbo].[MST_BUSYO] AS B ON (H.[BUSYO_CD]=B.[BUSYO_CD])
LEFT OUTER JOIN [SampleCorp1].[dbo].[MST_YAKU] AS Y ON (H.[YAKU_CD]=Y.[YAKU_CD])
WHERE S.[NYUSYA_YMD]<='2017-01-09'
 AND (S.[TAISYOKU_YMD] IS NULL OR S.[TAISYOKU_YMD]>'2017-01-09')
ORDER BY H.[BUSYO_CD],H.[YAKU_CD],H.[SCD];

このようになります。
先に「データベースへの接続方法」の最後でMDBの場合のSQL文を紹介してあるので比べてみて下さい。 「方言」的な違いがあるものの、それほどの違いがないことが判ると思います。
説明(やっていること)は「データベースへの接続方法」と全く同じなのでこちらでは割愛させていただきます。