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