EXCEL VBAでSQL文を使う

EXCEL VBAでSQL文を使って集計するでは、SELECT文を利用できましたが、INSERTやUPDATEにDELETEなどは利用できるのか試してみました。

集計で利用したEXCELシートにボタンを３つ追加してみました。

以下がテーブルになります。

INSERT文

「INSERT」ボタンが押されたときにデータを1件追加するようにしました。

7/20の日付でZさんが追加される予定です。

Private Sub cmdInsert_Click()
    Dim cn As ADODB.Connection
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer

    xl_file = ThisWorkbook.FullName
    
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open

    sql = "INSERT INTO [Sheet1$] " _
        & "  (日付, 名前, 勤務時間, 時給)" _
        & "  VALUES" _
        & "  ('2020/07/20', 'Zさん', 8, 850)"
    cn.Execute sql


    On Error Resume Next
    cn.Close
    Set cn = Nothing

End Sub

Private Sub cmdInsert_Click()

Dim cn As ADODB.Connection

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

xl_file = ThisWorkbook.FullName

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

sql = "INSERT INTO [Sheet1$] " _

& " (日付, 名前, 勤務時間, 時給)" _

& " VALUES" _

& " ('2020/07/20', 'Zさん', 8, 850)"

cn.Execute sql

On Error Resume Next

cn.Close

Set cn = Nothing

End Sub

INSERTボタンを押してから、Sheet1を表示したら一番下に追加されておりました。

UPDATE文

「UPDATE」ボタンが押されたときにZさんデータが更新されるようにしました。

勤務時間が８から１０に更新される予定です。

Private Sub Private Sub cmdUpdate_Click()
    Dim cn As ADODB.Connection
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer

    xl_file = ThisWorkbook.FullName
    
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open

    sql = "UPDATE [Sheet1$] " _
        & "  SET 勤務時間=10" _
        & "  WHERE 日付=#2020/07/20# AND 名前='Zさん'"
    cn.Execute sql


    On Error Resume Next
    cn.Close
    Set cn = Nothing
End Sub

Private Sub Private Sub cmdUpdate_Click()

Dim cn As ADODB.Connection

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

xl_file = ThisWorkbook.FullName

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

sql = "UPDATE [Sheet1$] " _

& " SET 勤務時間=10" _

& " WHERE 日付=#2020/07/20# AND 名前='Zさん'"

cn.Execute sql

On Error Resume Next

cn.Close

Set cn = Nothing

End Sub

UPDATE ボタンを押してから、Sheet1を表示したら一番下のZさんの勤務時間が更新されておりました。

DELETE文

「DELETE」ボタンが押されたときにZさんデータが削除されるようにしました。

Private Sub Private Sub cmdDelete_Click()
    Dim cn As ADODB.Connection
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer

    xl_file = ThisWorkbook.FullName
    
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open

    sql = "DELETE FROM [Sheet1$] " _
        & "  WHERE" _
        & "  日付=#2020/07/20# AND 名前='Zさん'"
    cn.Execute sql
    
    On Error Resume Next
    cn.Close
    Set cn = Nothing

End Sub

Private Sub Private Sub cmdDelete_Click()

Dim cn As ADODB.Connection

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

xl_file = ThisWorkbook.FullName

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

sql = "DELETE FROM [Sheet1$] " _

& " WHERE" _

& " 日付=#2020/07/20# AND 名前='Zさん'"

cn.Execute sql

On Error Resume Next

cn.Close

Set cn = Nothing

End Sub

エラーメッセージが表示され削除出来ませんでした。

「このISAMでは、リンクテーブル内のデータを削除することはできません。」

とりあえずUPDATE文で全ての項目にnullをセットして更新するしかないかも。

更新後は空の行として残ってしまうのでソートして最下行に移動させる様にします。

その後、追加すると空行の次にデータが追加されるのでもう一工夫します。

空行を削除してしまえば良いのですが、削除データが複数レコードになる場合も想定し、ソートして最下行になった空行からデータの範囲選択（ CTRL+SHIFT+ENDキーを押したときの動き）して取得できた最終行までを削除します。

Private Sub Private Sub cmdDelete_Click()
    Dim cn As ADODB.Connection
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer
    Dim lastRow As Integer<br>
    xl_file = ThisWorkbook.FullName
    
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open

'    sql = "DELETE FROM [Sheet1$] " _
'        & "  WHERE" _
'        & "  日付=#2020/07/20# AND 名前='Zさん'"
'    cn.Execute sql
    sql = "UPDATE [Sheet1$] " _
        & "  SET 日付=null, 名前=null, 勤務時間=null, 時給=null, 給料=null" _
        & "  WHERE 日付=#2020/07/20# AND 名前='Zさん'"
    cn.Execute sql


    Sheets("Sheet1").Select
    Sheets("Sheet1").Range("A1").Select
    Sheets("Sheet1").Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A2:A16") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("B2:B16") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:E16")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Sheet1").Range("A1").Select

    ' 空ではない最終行
    Selection.End(xlDown).Select
    ' 次の行の行番号
    curRow = ActiveCell.Row + 1
    ' 次の行のセル選択
    Sheets("Sheet1").Range("A" & curRow).Select
    ' CTRL+SHIFT+ENDキーを押したときの範囲選択
    Sheets("Sheet1").Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ' 選択行の最終行アドレスを取得
    lastRow = Selection.Cells.Rows.Count + curRow - 1
    ' 空行の先頭から最終行の行選択
    Sheets("Sheet1").Rows(curRow & ":" & lastRow).Select
    ' 行削除を実施
    Selection.Delete Shift:=xlUp
    Sheets("Sheet1").Range("A1").Select

    Sheets("Sheet2").Select

    On Error Resume Next
    cn.Close
    Set cn = Nothing

End Sub

Private Sub Private Sub cmdDelete_Click()

Dim cn As ADODB.Connection

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

Dim lastRow As Integer<br>

xl_file = ThisWorkbook.FullName

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

' sql = "DELETE FROM [Sheet1$] " _

' & " WHERE" _

' & " 日付=#2020/07/20# AND 名前='Zさん'"

' cn.Execute sql

sql = "UPDATE [Sheet1$] " _

& " SET 日付=null, 名前=null, 勤務時間=null, 時給=null, 給料=null" _

& " WHERE 日付=#2020/07/20# AND 名前='Zさん'"

cn.Execute sql

Sheets("Sheet1").Select

Sheets("Sheet1").Range("A1").Select

Sheets("Sheet1").Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A2:A16") _

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("B2:B16") _

, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Sheet1").Sort

.SetRange Range("A1:E16")

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Sheets("Sheet1").Range("A1").Select

' 空ではない最終行

Selection.End(xlDown).Select

' 次の行の行番号

curRow = ActiveCell.Row + 1

' 次の行のセル選択

Sheets("Sheet1").Range("A" & curRow).Select

' CTRL+SHIFT+ENDキーを押したときの範囲選択

Sheets("Sheet1").Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

' 選択行の最終行アドレスを取得

lastRow = Selection.Cells.Rows.Count + curRow - 1

' 空行の先頭から最終行の行選択

Sheets("Sheet1").Rows(curRow & ":" & lastRow).Select

' 行削除を実施

Selection.Delete Shift:=xlUp

Sheets("Sheet1").Range("A1").Select

Sheets("Sheet2").Select

On Error Resume Next

cn.Close

Set cn = Nothing

End Sub

これでなんちゃって削除が動くようになりました。

ソートしたくない場合は、ループで回して空行を見つけたら削除するような仕組みが必要だと思います。