ExcelでSQLを使う-027: ソース公開-11 SQLExecute関数-3（Excel To Excel）

16日齢を迎えた仔犬の体重は、1.47g～1.64Kgに達しました。

飲むオッパイの量も増えました。

それにつれて、ママ犬のフード量も激増しています。

180g×3+90g=630gが一日のフード量。

ママ犬は、通常の2.86倍のフードを食べてオッパイを出しています。

◇◇◇◇◇

９、エクセルでSQL文を実行するSQLExecute関数

 

９－３、SQLExecute関数で表に行を追加する

　今回は、メモ帳で『大田区新規顧客リスト』を編集してDドライブに保存。それを基にエクセルの＜顧客台帳＞の新規顧客を追加します。

まず、CircledText関数が、『大田区新規顧客リスト』をどのように読み込むのかを確認してみます。

CircleTextの1番目の引数: 実行するSQL文

CircleTextの2番目の引数: 戻り値にセットする行の番目

CircleTextの3番目の引数: Assessから読み込むかどうか？既定値はExcelブック

CircleTextの4番目の引数:読み込むDBないしExcelブック等のフルネーム

CircleTextの5番目の引数: ヘッダーの有無

Sub Macro7()

    Dim strSQL  As String
    Dim strXLF  As String
   
    strSQL = "SELECT * FROM [Sheet1$A1:G100]"
    strXLF = "D:\大田区新規顧客リスト.xlsx"
    Debug.Print 1 & ": " & CircledText(strSQL, 1, , strXLF, False)
    Debug.Print 2 & ": " & CircledText(strSQL, 2, , strXLF, False)
    Debug.Print 3 & ": " & CircledText(strSQL, 3, , strXLF, False)
    Debug.Print 4 & ": " & CircledText(strSQL, 4, , strXLF, False)
End Sub

[イミディエイトウインドウ]1: (F1,F2,F3,F4,F5,F6,F7) VALUES (125001,'裏山　登','うらやま　のぼる',1111250,'東京都','大田区','TT町')
2: (F1,F2,F3,F4,F5,F6,F7) VALUES (125002,'川上　清','かわかみ　きよし',1111250,'東京都','大田区','TT町')
3: (F1,F2,F3,F4,F5,F6,F7) VALUES (125003,'千原　宏','ちはら　ひろし',1111250,'東京都','大田区','TT町')
4:

　これだけわかれば、列名を書かないINSERT文で新規顧客を追加することができます。

列名を書かないINSERT文:

INSERT INT tablename VALUES (値1,値2,・・・値n)

Sub 新規顧客を追加する()
　　Dim StopNow　 As Boolean
　　Dim I　　　　　As Integer
　　Dim strSQL　　 As String
　　Dim strXLF　　 As String
　　Dim strList　　 As String
　　Dim strValues   As String
　　Dim strInsert_0 As String
　　Dim strInsert_1 As String
　　
　　strSQL = "SELECT * FROM [Sheet1$A1:G100]"
　　strXLF = "D:\大田区新規顧客リスト.xlsx"
　　strInsert_0 = "INSERT INTO [顧客名簿$A1:G100] VALUES XXXXX"
　　I = 0
　　Do
　　　　I = I + 1
　　　　strList = CircledText(strSQL, I, , strXLF, False)
　　　　strList = CutStr(strList, "VALUES", 2)
　　　　If Len(strList) > 0 Then
　　　　　　strInsert_1 = Replace(strInsert_0, "XXXXX", strList)
　　　　　　StopNow = SQLExecute(strInsert_1) <> True
　　　　End If
　　Loop Until Len(strList) = 0 Or StopNow
　　If StopNow Then
　　　　ErrorMsg "新規顧客を追加するマクロは中断しました。"
　　Else
　　　　Message "新規顧客を追加しました。"
　　End If
End Sub

Public Sub ErrorMsg(ByVal Msg As String)
　　MsgBox Msg, vbExclamation, " ｴﾗｰ発生のお知らせ"
End Sub

　次は、上記マクロの実行結果です。

 

SQLExecute関数のソースコードSQLExecute

　以下は、SQLExecute関数のソースコード全文です。DELETE文とDROP文を実行しないのであれば、冒頭の二つの関数のみをコピペしてSQLExecute関数から関連部分を削除してください。

Public Function SQLExecute(ByVal strSQL As String, _
                                           Optional ByVal xlFileName As String = "", _
                                           Optional ByVal isHeader As Boolean = True) As Boolean
    Dim isOK         As Boolean
    Dim strCommand   As String
    Dim strClearSQL  As String
    Dim strTableName As String

    Application.Calculation = xlCalculationManual
   
    isOK = True
    strCommand = CutStr(UCase(strSQL), " ", 1)
    Select Case strCommand
        Case "UPDATE", "INSERT"
            isOK = DoExecute(strSQL, xlFileName, isHeader)
        Case "DELETE"
            strClearSQL = Replace(UCase(strSQL), "DELETE", "SELECT *")
            isOK = RowsClear(strClearSQL, xlFileName, isHeader)
        Case "DROP"
            strClearSQL = Replace(UCase(strSQL), "TABLE", "")
            strClearSQL = Replace(strClearSQL, "DROP", "SELECT * FROM")
            isOK = RowsClear(strClearSQL, xlFileName, isHeader)
             If isOK Then
                strTableName = CutStr(CutStr(strSQL, "[", 2), "]", 1)
                isOK = DeleteHeader(strTableName)
            End If
        Case Else
            Message "UPDATE文、INSERT文、DERETE文、DROP文以外は実行できません！"
    End Select
   
    Application.Calculation = xlCalculationAutomatic
   
    SQLExecute = isOK
End Function

' ==============================
'  接続文字列のオプション IMEX
' ==============================
'
'   0‥‥エクスポートモード
'   1‥‥インポートモード
'   2‥‥リンクモード(省略=2)
'
Public Function DoExecute(ByVal strSQL As String, _
                                          Optional ByVal xlFileName As String = "", _
                                          Optional ByVal isHeader As Boolean = True) As Boolean
On Error GoTo Err_DoExecute
    Dim DataValue
    Dim isOK   As Boolean
    Dim strHDR As String
    Dim cnn    As ADODB.Connection
    Dim cmd    As ADODB.Command

    isOK = True
    '
    ' SET文
    '
    Set cnn = New ADODB.Connection
    Set cmd = New ADODB.Command
    '
    ' ThisWorkbook.FullName の指定
    '
    If Len(xlFileName) = 0 Then
         xlFileName = ThisWorkbook.FullName
    End If
    '
    ' 接続設定
    '
    With cnn
        strHDR = IIf(isHeader, "HDR=YES;", "HDR=NO;")
        .Provider = "Microsoft.ACE.OLEDB.12.0;"
        .Properties("Extended Properties") = "Excel 12.0;" & strHDR & "IMEX=0;"
        .Open xlFileName
        .Errors.Clear
        .BeginTrans
        With cmd
            .ActiveConnection = cnn
            .CommandText = strSQL
            .Execute
        End With
        .CommitTrans
    End With
Exit_DoExecute:
On Error Resume Next
    cnn.Close
    Set cnn = Nothing
    DoExecute = isOK
    Exit Function
Err_DoExecute:
    isOK = False
    If cnn.Errors.Count > 0 Then
        ErrMessage cnn.Errors(0), strSQL
        cnn.RollbackTrans
    Else
        MsgBox "プログラムエラーが発生しました。" & _
               "システム管理者に報告して下さい。(DoExecute)", _
               vbExclamation, " 関数エラーメッセージ"
    End If
    Resume Exit_DoExecute
End Function

Public Function RowsClear(ByVal strSQL As String, _
                                         Optional ByVal xlFileName As String = "", _
                                         Optional ByVal isHeader As Boolean = True) As Boolean
On Error GoTo Err_RowsClear
    Dim isOK      As Boolean
    Dim strHDR  As String
    Dim cnn       As Object 'ADOコネクションオブジェクト
    Dim rst        As Object 'ADOレコードセットオブジェクト
    Dim fld        As Object 'ADOフィールドオブジェクト
   
    isOK = True
    '
    ' ThisWorkbook.FullName の指定
    '
    If Len(xlFileName) = 0 Then
         xlFileName = ThisWorkbook.FullName
    End If
    '
    '  Set文
    '
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    '
    ' 接続
    '
    With cnn
        strHDR = IIf(isHeader, "HDR=YES;", "HDR=NO;")
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = strHDR & "IMEX=1;"
        .Properties("Extended Properties") = "Excel 12.0;"
        cnn.Open xlFileName
        With rst
            .Open Source:=strSQL, _
                ActiveConnection:=cnn, _
                CursorType:=adOpenDynamic, _
                LockType:=adLockOptimistic, _
                Options:=adCmdText
            If Not .BOF Then
                .MoveFirst
                Do
                    For Each fld In .Fields
                       If fld.Type <> 202 Then
                            fld.Value = Null
                        End If
                    Next fld
                    .Update
                    .MoveNext
                Loop Until (.EOF)
            End If
        End With
    End With
    ' -------------
    '  終了処理
    ' -------------
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    '
    '  空白行の削除
    '
    '  SELECT * FROM [XXXXX$A1:Z100] WHERE ID=10
    '
    Dim isClose       As Boolean
    Dim intRowMax     As Integer
    Dim intColMax     As Integer
    Dim intRow_S      As Integer
    Dim intCol_S      As Integer
    Dim strBookName   As String
    Dim strTableName  As String
    Dim strSheetname  As String
    Dim strRange_S    As String
    Dim objWorkbook   As Workbook
    Dim objWorksheet  As Worksheet
   
    strBookName = GetBookName(xlFileName)
    strTableName = CutStr(CutStr(strSQL, "[", 2), "]", 1)
    strSheetname = CutStr(strTableName, "$", 1)
    strRange_S = CutStr(CutStr(strTableName, "$", 2), ":", 1)
    intRow_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Row
    intCol_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Column
    '
    '  削除後の行数の取得
    '
    intRowMax = DLookup("SELECT COUNT(*) FROM " & "[" & strTableName & "]", , xlFileName, isHeader)
    If intRowMax > 0 And intColMax > 0 Then
        '
        '  Set文
        '
        If Not BookIsOpened(strBookName) Then
            isClose = True
            Set objWorkbook = Workbooks.Open(xlFileName)
            Set objWorksheet = objWorkbook.Worksheets(strSheetname)
        Else
            Set objWorksheet = Workbooks(strBookName).Worksheets(strSheetname)
        End If
        '
        '  空白行を消す
        '
        objWorksheet.Range(Cells(intRow_S, intCol_S), _
                           Cells(intRow_S + intRowMax - 1, _
                           intCol_S + intColMax - 1)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
        '
        '  外部ブックを閉じる
        '
        If isClose Then
            Application.DisplayAlerts = False 'メッセージを非表示に設定
            Workbooks(strBookName).Close True
            Application.DisplayAlerts = True  'メッセージを非表示に設定
        End If
        '
        '  終了処理
        '
        Set objWorkbook = Nothing
        Set objWorksheet = Nothing
    End If
Exit_RowsClear:
On Error Resume Next
    RowsClear = isOK
    Exit Function
Err_RowsClear:
    isOK = False
    MsgBox "SELECT 文の実行時にエラーが発生しました。(RowsClear)" & Chr$(13) & Chr$(13) & _
           "・Err.Description=" & Err.Description & Chr$(13) & _
           "・SQL Text=" & strSQL, _
           vbExclamation, " 関数ｴﾗｰﾒｯｾｰｼﾞ"
    Resume Exit_RowsClear
End Function

Public Function GetBookName(ByVal strFullName As String) As String
    Dim I               As Integer
    Dim N              As Integer
    Dim strDatas() As String
   
    strDatas() = Split(strFullName, "\")
    GetBookName = strDatas(UBound(strDatas()))
End Function

Public Function BookIsOpened(ByVal wbName As String) As Boolean
On Error Resume Next
    BookIsOpened = Len(Workbooks(wbName).Name & "") > 0
End Function

Public Function DeleteHeader(ByVal strTableName As String, _

                                               Optional ByVal xlFileName As String = "") As Boolean
On Error GoTo Err_DeleteHeader
    Dim isOK               As Boolean
    Dim isClose           As Boolean
    Dim intRow_S        As Integer
    Dim intCol_S          As Integer
    Dim intCol_E          As Integer
    Dim strRange_S      As String
    Dim strBookName   As String
    Dim strSheetname  As String
    Dim objWorkbook   As Workbook
    Dim objWorksheet  As Worksheet
   
    isOK = True
    '
    ' ThisWorkbook.FullName の指定
    '
    If Len(xlFileName) = 0 Then
         xlFileName = ThisWorkbook.FullName
    End If
    '
    '  準備
    '
    '  [XXXXX$A1:Z100]
    '
    '
    strBookName = GetBookName(xlFileName)
    strSheetname = CutStr(strTableName, "$", 1)
    strRange_S = CutStr(CutStr(strTableName, "$", 2), ":", 1)
    intRow_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Row
    intCol_S = Range(CutStr(CutStr(strTableName, "$", 2), ":", 1)).Column
    intCol_E = Range(CutStr(CutStr(strTableName, "$", 2), ":", 2)).Column
    '
    '  Set文
    '
    If Not BookIsOpened(strBookName) Then
        isClose = True
        Set objWorkbook = Workbooks.Open(xlFileName)
        Set objWorksheet = objWorkbook.Worksheets(strSheetname)
    Else
        Set objWorksheet = Workbooks(strBookName).Worksheets(strSheetname)
    End If
    '
    '  ヘッダー部を消す
    '
    '  Range(Columns(2), Columns(3)).Clear
    '
    objWorksheet.Range(Cells(intRow_S, intCol_S), _
                       Cells(intRow_S, intCol_S + intCol_E - 1)).Clear
    '
    '  外部ブックを閉じる
    '
    If isClose Then
        Application.DisplayAlerts = False 'メッセージを非表示に設定
        Workbooks(strBookName).Close True
        Application.DisplayAlerts = True  'メッセージを非表示に設定
    End If
    '
    '  終了処理
    '
    Set objWorkbook = Nothing
    Set objWorksheet = Nothing
Exit_DeleteHeader:
    DeleteHeader = isOK
    Exit Function
Err_DeleteHeader:
    isOK = False
    MsgBox "SELECT 文の実行時にエラーが発生しました。(RowsClear)" & Chr$(13) & Chr$(13) & _
           "・Err.Description=" & Err.Description & Chr$(13) & _
           vbExclamation, " 関数ｴﾗｰﾒｯｾｰｼﾞ"
    Resume Exit_DeleteHeader
End Function

　これまで、一列だけ検索する DLookup関数、一行だけ検索するElookup関数のソースを公開してきましたが、次は、複数行を検索するDSelect関数を紹介します。