VBA SQL実験用①(Access(mdb))

SQLの挙動を調べるのにエクセルから手軽にSQLを発行

Sub test()

Application.CommandBars("cell").Reset

End Sub

Sub auto_open()

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()

With ActiveSheet

tbl = InputBox("テーブル名")

Set cn = CreateObject("adodb.connection")
cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"

'テーブル削除

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(.Cells(Selection(1).Row, c).Value, 1)
    Case "s"
    tmp = "varchar" 'charは短いテキスト(varcharは可変長), textは長いテキスト
    Case "i"
    tmp = "integer"
  End Select
  
  fld = fld & .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 & .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 & "'" & .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

cn.Close
Set cn = Nothing

MsgBox "done"

End With

End Sub

Sub tt()

With ActiveSheet

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

cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"
rn.Open ActiveCell.Value, cn

'フィールド作成

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

'データ読込

ActiveCell.Offset(2, 0).CopyFromRecordset rn

rn.Close
Set rn = Nothing

cn.Close
Set cn = Nothing

End With

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

134

135

136

Sub test()

Application.CommandBars("cell").Reset

End Sub

Sub auto_open()

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()

With ActiveSheet

tbl = InputBox("テーブル名")

Set cn = CreateObject("adodb.connection")

cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"

'テーブル削除

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(.Cells(Selection(1).Row, c).Value, 1)

Case "s"

tmp = "varchar" 'charは短いテキスト(varcharは可変長), textは長いテキスト

Case "i"

tmp = "integer"

End Select

fld = fld & .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 & .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 & "'" & .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

cn.Close

Set cn = Nothing

MsgBox "done"

End With

End Sub

Sub tt()

With ActiveSheet

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"

rn.Open ActiveCell.Value, cn

'フィールド作成

i = 0

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

ActiveCell.Offset(1, i).Value = rn.Fields(i).Name

i = i + 1

Next c

'データ読込

ActiveCell.Offset(2, 0).CopyFromRecordset rn

rn.Close

Set rn = Nothing

cn.Close

Set cn = Nothing

End With

End Sub