データベース

SQL Server 2019 接続

'「Microsoft ActiveX Data Objects X.X Library」を有効にする。
Sub ConnectToSQLServer()
    ' 変数の宣言    Dim conn As ADODB.Connection    Dim rs As ADODB.Recordset    Dim connStr As String    Dim sqlStr As String    Dim col As Integer
    ' 接続文字列の設定' connStr = "Provider=SQLOLEDB;Data Source=YOUR_SERVER_NAME;Initial Catalog=YOUR_DATABASE_NAME;User ID=YOUR_USER_ID;Password=YOUR_PASSWORD;"    connStr = "Provider=SQLOLEDB;Data Source='KWT-DB01';Initial Catalog='TEST';UID=sa;PWD=;ConnectTimeout=60;"
    ' SQLクエリの設定' sqlStr = "SELECT * FROM YOUR_TABLE_NAME"    sqlStr = "SELECT * FROM Table_1"
    ' 接続の初期化    Set conn = New ADODB.Connection    Set rs = New ADODB.Recordset
    ' データベースに接続    conn.Open connStr
    ' レコードセットを開く    rs.Open sqlStr, conn
    ' 結果をシートに書き込む    Dim row As Long    row = 1    Do Until rs.EOF        For col = 0 To rs.Fields.Count - 1            ActiveSheet.Cells(row, col + 1).Value = rs.Fields(col).Value        Next col        rs.MoveNext        row = row + 1    Loop
    ' リソースの解放    rs.Close    conn.Close    Set rs = Nothing    Set conn = Nothing
    MsgBox "データの取得が完了しました！"    End Sub

Create文作成

Sub データベース_Create文作成()        'SQL（Innsert文）を作成する。        '移行データベース    Const const_テーブル名_移行 As String = "C3"    Const const_フィールド名_移行 As Integer = 2    Const const_型_移行 As Integer = 3    Const const_サイズ_移行 As Integer = 4    Const const_小数点_移行 As Integer = 5    Const const_NULL_移行 As Integer = 7    Const const_主キー_移行 As Integer = 7    Const const_データ型_移行 As Integer = 9    Const const_開始行_移行 As Integer = 7        '連携データベース    Const const_テーブル名_連携 As String = "E5"    Const const_フィールド名_連携 As Integer = 11    Const const_型_連携 As Integer = 19    Const const_サイズ_連携 As Integer = 23    Const const_小数点_連携 As Integer = 25    Const const_NULL_連携 As Integer = 27    Const const_主キー_連携 As Integer = 29    Const const_データ型_連携 As Integer = 19    Const const_開始行_連携 As Integer = 9        'データベース    Dim r_フィールド名 As Integer    Dim r_型 As Integer    Dim r_サイズ As Integer    Dim r_小数桁 As Integer    Dim r_NULL As Integer    Dim r_主キー As Integer    Dim r_データ型 As Integer    Dim r_開始行 As Integer    Dim w_テーブル名 As String    Dim w_データ型名 As String    Dim w_小数桁 As String        Dim w_str As String    Dim w_str_field As String    Dim w_str_null As String    Dim w_str_type As String    Dim w_str_key As String        Dim s As Worksheet    Dim r_start As Long    Dim r_end As Long    Dim c_start As Long    Dim c_end As Long    Dim i As Long    Dim j As Long        Set s = ActiveSheet    With s.UsedRange        r_start = .Row        r_end = .Row + .Rows.Count - 1        c_start = .Column        c_end = .Column + .Columns.Count - 1    End With        If s.Range("B5").Value = "フィールド名" Then        w_テーブル名 = const_テーブル名_移行        r_フィールド名 = const_フィールド名_移行        r_型 = const_型_移行        r_型 = const_型_移行        r_サイズ = const_サイズ_移行        r_小数桁 = const_小数点_移行        r_NULL = const_NULL_移行        r_主キー = const_主キー_移行        r_データ型 = const_データ型_移行        r_開始行 = const_開始行_移行    Else        w_テーブル名 = const_テーブル名_連携        r_フィールド名 = const_フィールド名_連携        r_型 = const_型_連携        r_サイズ = const_サイズ_連携        r_小数桁 = const_小数点_連携        r_NULL = const_NULL_連携        r_主キー = const_主キー_連携        r_データ型 = const_データ型_連携        r_開始行 = const_開始行_連携    End If        w_str_field = "CREATE TABLE [dbo].[" & s.Range(w_テーブル名).Value & "]("    For i = r_開始行 To r_end
        Application.StatusBar = i
        If s.Cells(i, r_フィールド名).Value <> "" Then                        If Trim(s.Cells(i, r_NULL).Value) <> "" Then                w_str_null = " NOT NULL,"            Else                w_str_null = " NULL,"            End If                        If s.Cells(i, r_データ型).Value <> "" Then                w_データ型名 = s.Cells(i, r_データ型).Value            Else                If s.Cells(i, r_型).Value = "数値" Then                    w_データ型名 = "DECIMAL"                ElseIf s.Cells(i, r_型).Value = "ﾃｷｽﾄ" Then                    w_データ型名 = "NVARCHAR"                ElseIf s.Cells(i, r_型).Value = "Yes/No" Then                    w_データ型名 = "bit"                ElseIf s.Cells(i, r_型).Value = "日付/時刻" Then                    w_データ型名 = "datetime"                Else                    w_データ型名 = s.Cells(i, r_型).Value                End If            End If                        If s.Cells(i, r_小数桁).Value = "" Then                w_小数桁 = 0            Else                w_小数桁 = s.Cells(i, r_小数桁).Value            End If                        If w_データ型名 = "DECIMAL" Then                w_str_type = "(" & s.Cells(i, r_サイズ).Value & "," & w_小数桁 & ")"                                ElseIf w_データ型名 = "numeric" Then                w_str_type = "(" & s.Cells(i, r_サイズ).Value & "," & w_小数桁 & ")"                            ElseIf w_データ型名 = "DATETIME" Then                w_str_type = ""                            ElseIf w_データ型名 = "BIT" Then                w_str_type = ""                            Else                w_str_type = "(" & s.Cells(i, r_サイズ).Value & ")"                            End If                        w_str_field = w_str_field & Chr(13) & " " _                & "[" & s.Cells(i, r_フィールド名).Value & "]" _                & "[" & w_データ型名 & "]" _                & w_str_type & w_str_null                End If    Next i        w_str_key = " CONSTRAINT [PK_" & s.Range(w_テーブル名).Value & "] PRIMARY KEY CLUSTERED " & Chr(13) & "("    For i = r_開始行 To r_end        Application.StatusBar = i        If Trim(s.Cells(i, r_主キー).Value) <> "" Then                    w_str_key = w_str_key & Chr(13) & " " & "[" & s.Cells(i, r_フィールド名).Value & "] ASC,"                    End If    Next i    w_str_key = Left(w_str_key, Len(w_str_key) - 1)    w_str_key = w_str_key & Chr(13) & ")WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON, OPTIMIZE_FOR_SEQUENTIAL_KEY = OFF) ON [PRIMARY]"    w_str_key = w_str_key & Chr(13) & ") ON [PRIMARY]"        On Error Resume Next    Err.Clear    ActiveSheet.Shapes.SelectAll    If Err.Number = 0 Then        If Selection.ShapeRange.Count > 0 Then            Selection.ShapeRange.Delete        End If    End If    On Error GoTo 0        w_str = "USE [KZSDB_xxxxx]" & Chr(13)    w_str = w_str & "GO" & Chr(13) & Chr(13)    w_str = w_str & "/****** Object: Table [dbo].[" & s.Range(w_テーブル名).Value & "] Script Date: " & Now & " ******/" & Chr(13)    w_str = w_str & "SET ANSI_NULLS ON" & Chr(13)    w_str = w_str & "GO" & Chr(13) & Chr(13)    w_str = w_str & "SET QUOTED_IDENTIFIER ON" & Chr(13)    w_str = w_str & "GO" & Chr(13) & Chr(13)    w_str = w_str & w_str_field & Chr(13) & w_str_key & Chr(13)    w_str = w_str & "GO"        ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 800, 100, 1000, 500).Select    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = w_str    ' MsgBox "終了"    Application.StatusBar = False    End Sub

接続実行切断

'「Microsoft ActiveX Data Objects X.X Library」を有効にする。
'Windows認証で接続する場合Public Const PROVIDER As String = "SQLOLEDB"Public DATA_SOURCE As String 'サーバ名Public DATABASE As String 'データベース名
'SQL Server認証で接続する場合Public Const USER_ID As String = "UID=user" 'ユーザIDPublic Const PASSWORD As String = "password" 'ユーザパスワード
Public cn As New ADODB.ConnectionPublic rs As New ADODB.Recordset
Public strSQL As String
Sub データベース_接続実行切断()
    '■ サーバー情報設定    DATA_SOURCE = "PC1665\SQLEXPRESS"    DATABASE = "KZSDB_xxxxx"        '--------------------------------    ' データベース接続    '--------------------------------    'Windows認証で接続する場合    cn.ConnectionString = "Provider=" & PROVIDER _                        & ";Data Source=" & DATA_SOURCE _                        & ";Initial Catalog=" & DATABASE _                        & ";Trusted_Connection=Yes"    cn.Open
' 'SQL Server認証で接続する場合' cn.ConnectionString = "Provider=" & PROVIDER _' & ";Data Source=" & DATA_SOURCE _' & ";Initial Catalog=" & DATABASE _' & ";UID=" & USER_ID _' & ";PWD=" & PASSWORD' cn.Open
    strSQL = "SELECT MAX([SIKIBETSUNO]) FROM TBL_JJYUKI"    Debug.Print strSQL        '--------------------------------    ' SQLの実行    '--------------------------------    If Not rs Is Nothing Then        Set rs = Nothing    End If    rs.Open strSQL, cn
    If rs.RecordCount > 0 Then        Debug.Print "⇒SIKIBETSUNO=" & rs![SIKIBETSUNO]    Else        Debug.Print "⇒s.RecordCount=" & rs.RecordCount    End If
    '--------------------------------    ' データベース切断    '--------------------------------    If Not rs Is Nothing Then        If rs.State = adStateOpen Then rs.Close        Set rs = Nothing    End If    If Not cn Is Nothing Then        If cn.State = adStateOpen Then cn.Close        Set cn = Nothing    End If
End Sub