VBA SQL実験用②(SQL Server)

以前、Accessにテーブルを手軽作成するエクセルVBAがあったので、今回はSQL Server版。クエリの複数行対応と、シート名でテーブル作成へ少し修正している。

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add
.OnAction = "t"
.Caption = "テーブル作成・登録"
End With

With Application.CommandBars("cell").Controls.Add
.OnAction = "tt"
.Caption = "SQL実行"
End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2
  Application.CommandBars("cell").Controls("テーブル作成・登録").Delete
  Application.CommandBars("cell").Controls("SQL実行").Delete
Next i

End Sub

Sub t()

Set cn = CreateObject("adodb.connection")
cn.Open "Provider=SQLOLEDB;Data Source=ESPRIMO\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

tbl = ActiveSheet.Name

'テーブル削除

On Error Resume Next
cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

  Select Case Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1)
    Case "s"
    tmp = "varchar(255)"
    Case "i"
    tmp = "bigint"
    Case "m"
    tmp = "money"
    Case "d"
    tmp = "date"
  End Select
  
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer identity(1,1) primary key," & fld & ")": Debug.Print q
cn.Execute q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & ","
Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row
  For cc = Selection(1).Column To Selection(Selection.Count).Column
    rec = rec & "'" & ActiveSheet.Cells(r, cc).Value & "'" & ","
  Next cc

  rec = Left(rec, Len(rec) - 1)
  
  q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")": Debug.Print q
  cn.Execute q

  rec = ""
Next r

If cn.State = 1 Then cn.Close
Set cn = Nothing

MsgBox "done"

End Sub

Sub tt()

Set cn = CreateObject("adodb.connection")
Set rn = CreateObject("adodb.recordset")

cn.Open "Provider=SQLOLEDB;Data Source=ESPRIMO\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

If Selection.Rows.Count = 1 Then
  rn.Open ActiveCell.Value, cn
Else
  For r = 1 To Selection.Rows.Count
    q = q & " " & Selection(r)
  Next r
  rn.Open q, cn: Debug.Print q
End If

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1
  Cells(Selection(Selection.Count).Row + 1, c).Value = rn.Fields(i).Name
  i = i + 1
Next c

'データ読込

Cells(Selection(Selection.Count).Row + 2, Selection(1).Column).CopyFromRecordset rn

If rn.State = 1 Then rn.Close
Set rn = Nothing

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add

.OnAction = "t"

.Caption = "テーブル作成・登録"

End With

With Application.CommandBars("cell").Controls.Add

.OnAction = "tt"

.Caption = "SQL実行"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("テーブル作成・登録").Delete

Application.CommandBars("cell").Controls("SQL実行").Delete

Next i

End Sub

Sub t()

Set cn = CreateObject("adodb.connection")

cn.Open "Provider=SQLOLEDB;Data Source=ESPRIMO\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

tbl = ActiveSheet.Name

'テーブル削除

On Error Resume Next

cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

Select Case Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1)

Case "s"

tmp = "varchar(255)"

Case "i"

tmp = "bigint"

Case "m"

tmp = "money"

Case "d"

tmp = "date"

End Select

fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer identity(1,1) primary key," & fld & ")": Debug.Print q

cn.Execute q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & ","

Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row

For cc = Selection(1).Column To Selection(Selection.Count).Column

rec = rec & "'" & ActiveSheet.Cells(r, cc).Value & "'" & ","

Next cc

rec = Left(rec, Len(rec) - 1)

q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")": Debug.Print q

cn.Execute q

rec = ""

Next r

If cn.State = 1 Then cn.Close

Set cn = Nothing

MsgBox "done"

End Sub

Sub tt()

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open "Provider=SQLOLEDB;Data Source=ESPRIMO\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

If Selection.Rows.Count = 1 Then

rn.Open ActiveCell.Value, cn

Else

For r = 1 To Selection.Rows.Count

q = q & " " & Selection(r)

Next r

rn.Open q, cn: Debug.Print q

End If

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1

Cells(Selection(Selection.Count).Row + 1, c).Value = rn.Fields(i).Name

i = i + 1

Next c

'データ読込

Cells(Selection(Selection.Count).Row + 2, Selection(1).Column).CopyFromRecordset rn

If rn.State = 1 Then rn.Close

Set rn = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub