ぼくLog

子持ち、車持ち、マンション持ちの僕の日常を綴ります。車と、ラクをしたい一心で覚えたエクセルVBAを中心になりそうです。

エクセルデータベースにSQLでデータ追加!|エクセルVBA

f:id:yt4u:20180212111117j:plain

まず前編はこれ。

yt4u.hatenablog.com


ここでエクセルのシートをデータベースのテーブルと見なし、そこからデータを取得する方法をまとめたわけですが、今回は


データの追加もSQL使ってものすっごぉぉっく簡単に出来ちゃいますって話です。


前回同様この住所録を使って、ここにデータを追加してみたいと思います。

f:id:yt4u:20170102225905j:plain

(住所録はなんちゃって個人情報で生成したダミーデータです。)


データを追加するためのプロシージャを用意します

前回は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


流れは、

  1. 新規追加するレコードのNoを現存するNoの最大値+1にするため、まずは現存するNoの最大値を取得
  2. 追加するレコードについてINSERT文を作成
  3. さっき用意したexecuteDBを実行してレコード追加。この時点でエクセルシート上にレコード追加完了
  4. データテーブルに割り当てられたセル範囲名(rngXDB_DataBase)の参照範囲を追加されたレコードを含むように修正



データ更新も可能です


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かよ!(古すぎて小声)




改めてコード全文を示します。

前回のコードも併せて改めて全文を載せます。


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

SQL逆引き大全363の極意

SQL逆引き大全363の極意