エクセルデータベースにSQLでデータ追加!|エクセルVBA
まず前編はこれ。
ここでエクセルのシートをデータベースのテーブルと見なし、そこからデータを取得する方法をまとめたわけですが、今回は
データの追加もSQL使ってものすっごぉぉっく簡単に出来ちゃいますって話です。
前回同様この住所録を使って、ここにデータを追加してみたいと思います。
(住所録はなんちゃって個人情報で生成したダミーデータです。)
データを追加するためのプロシージャを用意します
前回はGetRecordsetのプロシージャのみでしたが、データを追加(Execute)するためのプロシージャを用意します。
Private mstrErrDescription As String Private Const mcDataRangeName As String = "rngXDB_DataBase" '========================================================== 'Execute '========================================================== Public Function executeDB( _ ByRef objCN As Object, _ ByVal strSQL As String _ ) As Boolean executeDB = False On Error GoTo ERR_PROC objCN.execute strSQL executeDB = True GoTo END_PROC ERR_PROC: mstrErrDescription = "Executeエラー" END_PROC: End Function
なお
Private mstrErrDescription As String
はエラー内容を返すための変数。
Private Const mcDataRangeName As String = "rngXDB_DataBase"
はシート上のデータテーブルに割り当てられたセル範囲名を示す定数。
データ追加してみます
で、早速データを追加してみます。
'========================================================== 'データ追加サンプル '========================================================== Public Sub addDataSample() Dim objCN As Object Dim objRS As Object Dim strSQL As String Dim lngMaxNo As Long 'コネクションを確立 Set objCN = GetXLSConnection(ThisWorkbook.FullName) 'Noの最大値を取得 strSQL = "SELECT" strSQL = strSQL & " MAX([No]) AS MaxNo" strSQL = strSQL & " FROM " & mcDataRangeName If getRecordset(objCN, strSQL, objRS) = False Then GoTo ERR_PROC End If lngMaxNo = objRS!MaxNo '登録条件を作成 strSQL = "INSERT INTO " & mcDataRangeName strSQL = strSQL & "(" strSQL = strSQL & " [No]" strSQL = strSQL & ", [名前]" strSQL = strSQL & ", [ふりがな]" strSQL = strSQL & ", [性別]" strSQL = strSQL & ", [年齢]" strSQL = strSQL & ", [誕生日]" strSQL = strSQL & ", [婚姻]" strSQL = strSQL & ", [血液型]" strSQL = strSQL & ", [都道府県]" strSQL = strSQL & ", [電話番号]" strSQL = strSQL & ", [携帯]" strSQL = strSQL & ", [キャリア]" strSQL = strSQL & ", [カレーの食べ方]" strSQL = strSQL & ")" strSQL = strSQL & "VALUES" strSQL = strSQL & "(" strSQL = strSQL & " " & lngMaxNo + 1 strSQL = strSQL & ", '手酢十'" strSQL = strSQL & ", 'テスト'" strSQL = strSQL & ", '男'" strSQL = strSQL & ", 99" strSQL = strSQL & ", #2000/1/1#" strSQL = strSQL & ", '未婚'" strSQL = strSQL & ", 'AB型'" strSQL = strSQL & ", '東京都'" strSQL = strSQL & ", '00-0000-0000'" strSQL = strSQL & ", '999-9999-9999'" strSQL = strSQL & ", 'au'" strSQL = strSQL & ", '奥ルー・別口派'" strSQL = strSQL & ")" If executeDB(objCN, strSQL) = False Then GoTo ERR_PROC End If 'データセル範囲を修正 With wsXLSDataBase With .Range(mcDataRangeName) ThisWorkbook.Names.Add mcDataRangeName, .CurrentRegion End With End With GoTo END_PROC ERR_PROC: MsgBox mstrErrDescription END_PROC: 'コネクションを閉じる Call CloseConnection(objCN) End Sub
流れは、
- 新規追加するレコードのNoを現存するNoの最大値+1にするため、まずは現存するNoの最大値を取得
- 追加するレコードについてINSERT文を作成
- さっき用意したexecuteDBを実行してレコード追加。この時点でエクセルシート上にレコード追加完了
- データテーブルに割り当てられたセル範囲名(rngXDB_DataBase)の参照範囲を追加されたレコードを含むように修正
Excel 最強の教科書[完全版]――すぐに使えて、一生役立つ「成果を生み出す」超エクセル仕事術
- 作者: 藤井直弥,大山啓介
- 出版社/メーカー: SBクリエイティブ
- 発売日: 2017/01/28
- メディア: 単行本
- この商品を含むブログ (2件) を見る
データ更新も可能です
INSERTが出来た次はUPDATEですね。
先ほどのデータテーブルでNoが最大値となっているレコードの名前をNULLにしたいと思います。
'========================================================== 'データ更新サンプル '========================================================== Public Sub updateDataSample() Dim objCN As Object Dim objRS As Object Dim strSQL As String Dim lngMaxNo As Long 'コネクションを確立 Set objCN = GetXLSConnection(ThisWorkbook.FullName) 'Noの最大値を取得 strSQL = "SELECT" strSQL = strSQL & " MAX([No]) AS MaxNo" strSQL = strSQL & " FROM " & mcDataRangeName If getRecordset(objCN, strSQL, objRS) = False Then GoTo ERR_PROC End If lngMaxNo = objRS!MaxNo 'Update文作成 strSQL = "UPDATE " & mcDataRangeName strSQL = strSQL & " SET " strSQL = strSQL & " [名前] = NULL" strSQL = strSQL & " WHERE 1 = 1 " strSQL = strSQL & " AND [No] = " & lngMaxNo If executeDB(objCN, strSQL) = False Then GoTo ERR_PROC End If GoTo END_PROC ERR_PROC: MsgBox Err.Description END_PROC: 'コネクションを閉じる Call CloseConnection(objCN) End Sub
レコードの削除もしちゃう?
INSERT、UPDATEと来たら次はDELETEですね。
これ、出来ません。
やろうとしても「この ISAM では、リンク テーブル内のデータを削除することはできません。」って怒られます。SHAZNAかよ!(古すぎて小声)
10年戦えるデータ分析入門 SQLを武器にデータ活用時代を生き抜く (Informatics &IDEA)
- 作者: 青木峰郎
- 出版社/メーカー: SBクリエイティブ
- 発売日: 2015/06/30
- メディア: 単行本
- この商品を含むブログ (7件) を見る
改めてコード全文を示します。
前回のコードも併せて改めて全文を載せます。
Option Explicit Private Const adOpenDynamic As Long = 2 Private Const adLockOptimistic As Long = 3 Private Const adStateClosed As Long = 0 Private mstrErrDescription As String Private Const mcDataRangeName As String = "rngXDB_DataBase" '========================================================== 'コネクションを返す '========================================================== Public Function GetXLSConnection(DataSource As String) As Object Dim objCN As Object Dim strCNString As String Set objCN = CreateObject("ADODB.Connection") strCNString = "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & DataSource & ";" _ & "Extended Properties=""Excel 8.0;" _ & "HDR=Yes"";" objCN.Open strCNString Set GetXLSConnection = objCN End Function '========================================================== 'GetRecordset '========================================================== Public Function getRecordset( _ ByRef objCN As Object, _ ByVal strSQL As String, _ ByRef objRS As Object _ ) As Boolean getRecordset = False On Error GoTo ERR_PROC Set objRS = CreateObject("ADODB.Recordset") objRS.Open strSQL, objCN, adOpenDynamic, adLockOptimistic getRecordset = True GoTo END_PROC ERR_PROC: mstrErrDescription = "レコードセット生成エラー" END_PROC: End Function '========================================================== 'Execute '========================================================== Public Function executeDB( _ ByRef objCN As Object, _ ByVal strSQL As String _ ) As Boolean executeDB = False On Error GoTo ERR_PROC objCN.execute strSQL executeDB = True GoTo END_PROC ERR_PROC: mstrErrDescription = "Executeエラー" END_PROC: End Function '========================================================== 'コネクション破棄 '========================================================== Public Sub CloseConnection(objCN As Object) If objCN.State <> adStateClosed Then objCN.Close End If Set objCN = Nothing End Sub '========================================================== 'レコードセット破棄 '========================================================== Public Sub CloseRecordSet(objRS As Object) If objRS.State <> adStateClosed Then objRS.Close End If Set objRS = Nothing End Sub '========================================================== 'データ取得サンプル '========================================================== Public Sub GetDataSample() Dim objCN As Object Dim objRS As Object Dim strSQL As String Dim lngF As Long 'コネクションを確立 Set objCN = GetXLSConnection(ThisWorkbook.FullName) '抽出条件を作成 strSQL = "SELECT" '抽出フィールド(項目)を指定 strSQL = strSQL & " [名前]" strSQL = strSQL & ", [ふりがな]" strSQL = strSQL & ", [電話番号]" strSQL = strSQL & ", MONTH([誕生日]) AS [誕生月]" strSQL = strSQL & " FROM " & mcDataRangeName 'データテーブルを指定 strSQL = strSQL & " WHERE 1 = 1" '抽出条件 strSQL = strSQL & " AND [性別] = '男'" '性別=男 strSQL = strSQL & " AND [年齢] >= 30" '年齢=30歳以上 strSQL = strSQL & " AND [年齢] < 50" '50歳未満 strSQL = strSQL & " AND [婚姻] = '未婚'" '婚姻=未婚 '抽出実行 If getRecordset(objCN, strSQL, objRS) = False Then GoTo ERR_PROC End If '抽出結果を出力 With wsXLSDataBase With .Range("rngXDB_DataTop") '出力エリアにある既存データを消去 .CurrentRegion.ClearContents 'フィールド(項目)名を出力 For lngF = 0 To objRS.Fields.Count - 1 .Offset(, lngF).Value = objRS.Fields(lngF).Name Next lngF 'データを出力 .Offset(1).CopyFromRecordset objRS End With End With GoTo END_PROC ERR_PROC: MsgBox mstrErrDescription END_PROC: 'レコードセットを閉じる Call CloseRecordSet(objRS) 'コネクションを閉じる Call CloseConnection(objCN) End Sub '========================================================== 'データ追加サンプル '========================================================== Public Sub addDataSample() Dim objCN As Object Dim objRS As Object Dim strSQL As String Dim lngMaxNo As Long 'コネクションを確立 Set objCN = GetXLSConnection(ThisWorkbook.FullName) 'Noの最大値を取得 strSQL = "SELECT" strSQL = strSQL & " MAX([No]) AS MaxNo" strSQL = strSQL & " FROM " & mcDataRangeName If getRecordset(objCN, strSQL, objRS) = False Then GoTo ERR_PROC End If lngMaxNo = objRS!MaxNo '登録条件を作成 strSQL = "INSERT INTO " & mcDataRangeName strSQL = strSQL & "(" strSQL = strSQL & " [No]" strSQL = strSQL & ", [名前]" strSQL = strSQL & ", [ふりがな]" strSQL = strSQL & ", [性別]" strSQL = strSQL & ", [年齢]" strSQL = strSQL & ", [誕生日]" strSQL = strSQL & ", [婚姻]" strSQL = strSQL & ", [血液型]" strSQL = strSQL & ", [都道府県]" strSQL = strSQL & ", [電話番号]" strSQL = strSQL & ", [携帯]" strSQL = strSQL & ", [キャリア]" strSQL = strSQL & ", [カレーの食べ方]" strSQL = strSQL & ")" strSQL = strSQL & "VALUES" strSQL = strSQL & "(" strSQL = strSQL & " " & lngMaxNo + 1 strSQL = strSQL & ", '手酢十'" strSQL = strSQL & ", 'テスト'" strSQL = strSQL & ", '男'" strSQL = strSQL & ", 99" strSQL = strSQL & ", #2000/1/1#" strSQL = strSQL & ", '未婚'" strSQL = strSQL & ", 'AB型'" strSQL = strSQL & ", '東京都'" strSQL = strSQL & ", '00-0000-0000'" strSQL = strSQL & ", '999-9999-9999'" strSQL = strSQL & ", 'au'" strSQL = strSQL & ", '奥ルー・別口派'" strSQL = strSQL & ")" If executeDB(objCN, strSQL) = False Then GoTo ERR_PROC End If 'データセル範囲を修正 With wsXLSDataBase With .Range(mcDataRangeName) ThisWorkbook.Names.Add mcDataRangeName, .CurrentRegion End With End With GoTo END_PROC ERR_PROC: MsgBox mstrErrDescription END_PROC: 'コネクションを閉じる Call CloseConnection(objCN) End Sub '========================================================== 'データ更新サンプル '========================================================== Public Sub updateDataSample() Dim objCN As Object Dim objRS As Object Dim strSQL As String Dim lngMaxNo As Long 'コネクションを確立 Set objCN = GetXLSConnection(ThisWorkbook.FullName) 'Noの最大値を取得 strSQL = "SELECT" strSQL = strSQL & " MAX([No]) AS MaxNo" strSQL = strSQL & " FROM " & mcDataRangeName If getRecordset(objCN, strSQL, objRS) = False Then GoTo ERR_PROC End If lngMaxNo = objRS!MaxNo 'Update文作成 strSQL = "UPDATE " & mcDataRangeName strSQL = strSQL & " SET " strSQL = strSQL & " [名前] = NULL" strSQL = strSQL & " WHERE 1 = 1 " strSQL = strSQL & " AND [No] = " & lngMaxNo If executeDB(objCN, strSQL) = False Then GoTo ERR_PROC End If GoTo END_PROC ERR_PROC: MsgBox Err.Description END_PROC: 'コネクションを閉じる Call CloseConnection(objCN) End Sub
- 作者: 株式会社アシスト
- 出版社/メーカー: 秀和システム
- 発売日: 2013/06/28
- メディア: 単行本
- この商品を含むブログ (2件) を見る