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 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シートから初期データを一括投入する。
-
先頭の画像をクリックしてダウンロードされる圧縮ファイルを解凍すると「SQLインポートデータ(SAMPLE).xlsm」が現われます。 これがそのシートの画像ですが、シート構成と内容は「ワークシートからデータベースに一括登録」と全く同じものです。
こちらの「SQLインポートデータ(SAMPLE).xlsm」の方はマクロがSQL Serverに合わせて作成しているのですが、 実行に先立って、SQL Server接続時の認証情報等を変更していただく必要があります。
'*************************************************************************************************** ' SQLServer初期データインポートツール ' ' 作成者:井上治 URL:https://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認証で利用される場合はどちらもブランクで構いません。
マクロの環境変更ができたらマクロ「SQLServer初期データインポート」を実行します。
正常ならば処理はほぼ瞬時に完了すると思います。
正常に完了した場合はこのようにメッセージが表示されます。 異常がある場合はその旨のメッセージが表示されます。
実際に投入されたデータの状況は「Microsoft SQL Server Management Studio」でこのように見ることができます。
- では各マスタデータから「配属一覧」を出力してみましょう。
-
これが「SQL配属一覧.xlsm」を開いたところです。
上の「SQLインポートデータ(SAMPLE).xlsm」と同様にソースコードの先頭に接続設定があるので、 マクロの実行に先立って、SQL Server接続時の認証情報等を変更していただく必要があります。
変更ができたらマクロ「GetSqlDataByADO」を実行して下さい。
問題なければこのように配属一覧が表示されます。
- ここからはソースコードを紹介します。まずは「SQLServerテーブル定義ツール」です。
-
「ダウンロード」の「SQLServerテーブル定義ツール」のページではソースコードの紹介は行なっていません。
これは「そのまま利用できる」ということからですが、こちらで紹介することにします。
この処理はシート上に登録された内容に従ってテーブルを作成するスクリプトを出力するもので、直接SQL Serverのテーブルを作成するわけではありません。 従って、SQL Serverへの認証の問題などもないわけです。'*************************************************************************************************** ' テーブル作成Script生成(for SQLServer：2005 or Later) ' ' 作成者:井上治 URL:https://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①", "Index②", "Index③", "Index④", "Index⑤") 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 '* 機能 ：エラーメッセージ編集②(シート名、行番号付加) '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：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 >>--------------------------------------
ソースコードは大変長い(900行以上)ですが、半分以上はシート上の内容チェックに費やされています。
- 次は「SQLインポートデータ(SAMPLE).xlsm」です。
-
'*************************************************************************************************** ' SQLServer初期データインポートツール ' ' 作成者:井上治 URL:https://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:https://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文を紹介してあるので比べてみて下さい。 「方言」的な違いがあるものの、それほどの違いがないことが判ると思います。
なお、テーブルID、フィールドIDがそれぞれ「カギ括弧("["、"]")」で囲われているのは、 テーブルID、フィールドIDに空白文字が含まれる場合の処置であり、 このサンプルでは空白文字は含まれないので「カギ括弧("["、"]")」は削除しても構いません。
説明（やっていること）は「データベースへの接続方法」と全く同じなのでこちらでは割愛させていただきます。