VBA : SQLSelectSelected マクロ : バインド変数対応

 すでに公開した、Excel のみで SQL を実行できる、自画自賛の SQL 検証ツールだ。

 今回は、実行する SQL文でバインド変数を使えるように改修してみたぞ。

 

 ex.

   while sheet1@テストマスタ.項番 = sheet2%param1

   

 sheet2 の任意セルに、範囲がsheet2の"名前" を定義すれば、当該セルの内容を param1 として SQLに渡すことができる

 

 注意点

 ・範囲がブックの"名前"は処理されない

 ・テーブル名と同様に、SQL文と同一シートにある"名前"はシート名を省略して記載できる

   ... sheet1 の SQL で sheet1 の"名前" param2 を使う ⇒ "sheet1%param2" or "%param2"

 

 ・"名前"のセル範囲中、左上のセルの値が受け渡される

 ・"名前"の示すセルの表示形式が文字列(@)の場合、SQLにはシングルクォート(')の引用符が自動付加される

 

 以下、バインド変数を付加し、リテラルの確認を付加したSQLのサンプルだ

 

 select 本人.項番

  ,本人.氏名 as 本人氏名

  ,家族.*

  ,'123abc' as リテラル

  ,"123abc" as リテラル2

 from sheet1@testtable as 本人

 INNER JOIN sheet2@家族 as 家族

 on 本人.項番 = 家族.社員番号

 where 本人.項番 = '1'

 and 家族.項番 > sheet1%param1

 

 

 バインドに直接関係ないが、本マクロSQLやExcelSQLの文法上の制限をまとめた

 本マクロのSQL文法は、ExcelSQL文法(AccessSQL)にテーブル名指定法とバインド変数指定法を拡張したものだ

 

 ・本マクロのSQL文法／テーブル指定法

     [<シート名>]@<excelテーブル名>

 

 ・本マクロのSQL文法／バインド変数指定法

     [<シート名>]%<シート範囲の"名前">

 

     シート名、テーブル名は半角英数、全角カタカナひらがな漢字、半角アンダーバーが使用できる

     全角認識はアバウトなので許してくれ

 

 ・ExcelSQL文法／変数型

     基本的にバリアント型なので、数値のように扱えば数値、文字のように扱えば文字としてふるまう

     しかし、SQL中にリテラルを記述する場合、明確に文字列として記載するので、テーブル項目側も型を明確にする必要がある

     具体的には、Excelテーブル(表組)中で文字列として扱う項目のデータは、表示形式を文字型に設定しなくてはいけない

     

     1.バリアントのままSQLで使用する場合

         data = ABC

         

     2.文字型であることを明確にする場合

         data = 'ABC' または data = "ABC"

         

 ・ExcelSQL文法／引用符

     ダブル／シングルクォート("),(')のどちらでも使用できるが、文字列型バインド変数の場合シングルクォートを付加している

     ただしセル中では先頭のシングルクォートは非表示となり、実際のデータからも排除される

     先頭にシングルクォートを記載しなくてはいけない場合、手前に1文字の半角スペースを付加して、シングルクォートが消えないように留意しろし

Ora2MsSQL.bas ※2020/11/27更新

Attribute VB_Name = "Ora2MsSQL" ' 正規表現用Objectは実行回数が多いので、共用し、Objectの破棄も行わない Dim RE1 As Object Dim RE2 As Object Dim RE5 As Object Dim RE6 As Object Dim nt As Long Dim deb As Boolean Dim debset As Boolean Public Sub heartbeet(Optional strn As String = "*") If debset = False Then If ActiveSheet.Range("$A$1").Value = "deb" Then deb = True debset = True End If If deb = True Then Debug.Print Timer() - nt & "," & strn nt = Timer() End If End Sub '---・SQL文のExcel用SQLへの変換(表示確認用) Public Function Oracle2MsSql(Rng As Range) As String Oracle2MsSql = Ora2MsSqlText(ConcatSep(Rng, " ", vbLf)) End Function '---正規表現検索 '正規表現用 object の開け閉めを減らすため、呼出し上位で Object を管理する。 '∴ワークシート関数としては使えない Public Function RegSch(REE As Object, strTarget As String, strPat As String, Optional IgnoreCase As Boolean = True, Optional bGlobal As Boolean = False) As Object With REE .Pattern = strPat .IgnoreCase = IgnoreCase .Global = bGlobal End With Set RegSch = REE.Execute(strTarget) End Function '---正規表現置換 '正規表現用 object の開け閉めを減らすため、呼出し上位で Object を管理する。 '∴ワークシート関数としては使えない Public Function RegChg(REE As Object, strTarget As String, strPat As String, para As String, Optional Ignore As Boolean = True) As String Dim ret As String With REE .Pattern = strPat .IgnoreCase = Ignore .Global = True End With RegChg = REE.Replace(strTarget, para) End Function '---セル内容結合関数 'セル範囲のテキストを、セル内改行をセパレータにして１テキストに結合するため Public Function ConcatSep(Rng As Range, Optional sep As String = vbLf, Optional sep2 As String = vbLf) As String ConcatSep = "" Dim nSelCount As Integer nSelCount = Rng.Cells.Count rightcolumn = Rng.Cells(Rng.Cells.Count).Column For Each cel In Rng.Cells ConcatSep = ConcatSep & cel.Value nSelCount = nSelCount - 1 If (nSelCount > 0) Then ConcatSep = ConcatSep & sep If cel.Column = rightcolumn Then ConcatSep = ConcatSep & sep2 End If End If Next End Function Function CASE_(str1 As String) As String Dim ret As Object Dim ret2 As Object Dim ret3 As Object Dim str2 As String str1 = RegChg(RE1, str1, "[ ]+", " ") Set ret3 = RegSch(RE1, str1, "\bCASE (.*?) WHEN", True, True) ifword = ret3(0).submatches(0) Set ret2 = RegSch(RE1, str1, "\b(WHEN|ELSE|END)\b", True, True) elseWord = "NULL" For i = ret2.Count - 1 To 1 Step -1 findoffset = Len(ret2(i - 1).Value) str2 = Mid(str1, ret2(i - 1).firstindex + findoffset + 2, ret2(i).firstindex - ret2(i - 1).firstindex - findoffset - 2) Set ret3 = RegSch(RE2, str2, "(.*)\bTHEN\b(.*)", True, True) If ret3.Count = 0 Then elseWord = str2 Else elseWord = "iif(" & ifword & " = " & ret3(0).submatches(0) & "," & ret3(0).submatches(1) & ";;," & elseWord & ")" End If Next CASE_ = elseWord End Function Function CASEWHEN(str1 As String) As String Dim ret As Object Dim ret2 As Object Dim ret3 As Object Dim str2 As String str1 = RegChg(RE1, str1, "[ ]+", " ") Set ret2 = RegSch(RE1, str1, "\b(WHEN|ELSE|END CASE)\b", True, True) elseWord = "NULL" For i = ret2.Count - 1 To 1 Step -1 findoffset = Len(ret2(i - 1).Value) str2 = Mid(str1, ret2(i - 1).firstindex + findoffset + 2, ret2(i).firstindex - ret2(i - 1).firstindex - findoffset - 2) Set ret3 = RegSch(RE2, str2, "(.*)\bTHEN\b(.*)", True, True) If ret3.Count = 0 Then elseWord = str2 Else elseWord = "iif(" & ret3(0).submatches(0) & "," & ret3(0).submatches(1) & ";;," & elseWord & ")" End If Next CASEWHEN = elseWord End Function Function CONV_CASE_WHEN_CASE_END(ConvSQLText As String) As String Dim ret As Object Dim ret2 As Object Dim str0 As String Dim str2 As String Dim str3 As String Dim str1 As String On Error GoTo ern ConvSQLText = Replace(ConvSQLText, Chr(10), ";;") 'case出現箇所抽出 Set ret = RegSch(RE5, ConvSQLText, "\bCASE\b", True, True) 'end case出現箇所抽出 Set ret2 = RegSch(RE6, ConvSQLText, "\bEND\b[\s\r\n;]+\bCASE\b", True, True) 'case出現箇所を後方から繰り返し If ret.Count = 0 Then CONV_CASE_WHEN_CASE_END = Replace(ConvSQLText, ";;", Chr(10)) Exit Function End If '入れ子でも正しく動作させるため、最後の CASE から先頭に向けてループ処理を行う For i = ret.Count - 1 To 0 Step -1 bAboid = False For j = 0 To ret2.Count - 1 pos = ret2(j).firstindex + Len(ret2(j).Value) - 4 '処理中の case が END CASE の 'case' の場合、飛ばしてもう一つ手前の case を処理する 'このEND CASE は、対応する CASE が 外側のループで処理されるまで文字列中に残る If ret(i).firstindex = pos Then bAboid = True '一つ飛ばし Exit For End If Next ' 'end case出現箇所以外を処理 If bAboid = False Then str0 = Left(ConvSQLText, ret(i).firstindex) str1 = Right(ConvSQLText, Len(ConvSQLText) - ret(i).firstindex) 'case XXX when end か判断 Set ret2 = RegSch(RE6, str1, "CASE[\s;\n]+[^\s;\n]+[\s;\n]+WHEN[\s\r\n]+.*?END", True, True) If (ret2.Count > 0) Then 'case xxxx when ~ END If ret2(0).firstindex > 0 Then Error (1) End If str2 = Left(str1, Len(ret2(0).Value)) str2 = Replace(str2, ";;", " ") str2 = Replace(str2, " ", " ") str2 = CASE_(str2) ConvSQLText = str0 & str2 & Right(str1, Len(str1) - Len(ret2(0).Value)) Else Set ret2 = RegSch(RE6, str1, "CASE[\s;\n]+WHEN[\s;\n]+.*?END[\s;\n]+CASE", True, True) If (ret2.Count > 0) Then 'case when ~ END case If ret2(0).firstindex > 0 Then Error (1) End If str2 = Left(str1, Len(ret2(0).Value)) str2 = Replace(str2, ";;", " ") str2 = Replace(str2, " ", " ") str2 = CASEWHEN(str2) ConvSQLText = str0 & str2 & Right(str1, Len(str1) - Len(ret2(0).Value)) Else 'case error Error (1) End If End If ' Debug.Print ConvSQLText 'end case出現箇所抽出 Set ret2 = RegSch(RE6, ConvSQLText, "\bEND\b[\s\r\n]+\bCASE\b", True, True) '置き換えが発生した場合、最後尾からやり直し ' i = ret.Count End If Next CONV_CASE_WHEN_CASE_END = Replace(ConvSQLText, ";;", Chr(10)) Exit Function ern: CONV_CASE_WHEN_CASE_END = "CASE ERROR" End Function Function CONV_DECODE(ConvSQLText As String) As String Dim ret As Object Dim resultx(126) As String On Error GoTo ern nWords = 0 ConvSQLText = Replace(ConvSQLText, Chr(10), ";;") 'DECOSE出現箇所抽出 Set ret = RegSch(RE6, ConvSQLText, "\bDECODE[\s\r\n;]*\(", True, True) 'DECODE出現箇所を後方から繰り返し If ret.Count = 0 Then CONV_DECODE = Replace(ConvSQLText, ";;", Chr(10)) Exit Function End If For i = ret.Count - 1 To 0 Step -1 bAboid = False '括弧のネストを確認しながら、"DECODE(" に対応する ")"までの文字列を対象として、入れ子外の ","で '項目を区切り、要素分割した結果を配列に格納する nNest = 0 bWordTop = True For j = ret(i).firstindex + Len(ret(i).Value) To Len(ConvSQLText) c = Mid(ConvSQLText, j, 1) ' Debug.Print c, nNest If (c = "(") Then nNest = nNest + 1 GoTo F1End ElseIf (c = ")") Then nNest = nNest - 1 End If If nNest < 1 Then Exit For If nNest = 1 Then If bWordTop Then bWordTop = False nWordTop = j End If If (c = ",") Then nWordEnd = j bWordTop = True resultx(nWords) = Trim(Replace(Mid(ConvSQLText, nWordTop, nWordEnd - nWordTop), ";", "")) nWords = nWords + 1 End If Else End If F1End: Next resultx(nWords) = Trim(Replace(Mid(ConvSQLText, nWordTop, j - nWordTop), ";", "")) nWords = nWords + 1 Next str1 = Left(ConvSQLText, ret(0).firstindex) str2 = Right(ConvSQLText, Len(ConvSQLText) - j) elseWord = resultx(nWords - 1) ifword = resultx(0) For i = nWords - 3 To 1 Step -2 elseWord = "iif(" & ifword & " = " & resultx(i) & ", " & resultx(i + 1) & ", " & elseWord & ")" Next ConvSQLText = str1 & elseWord & str2 CONV_DECODE = Replace(ConvSQLText, ";;", Chr(10)) Exit Function ern: CONV_DECODE = "DECODE ERROR" End Function '---・SQL文のExcel用SQLへの変換 Public Function Ora2MsSqlText(SQLText As String) As String Dim ret As Object Dim shnn, tbn As String ' 正規表現用Objectは実行回数が多いので、共用し、ここで初期化する Set RE1 = CreateObject("VBScript.RegExp") Set RE2 = CreateObject("VBScript.RegExp") Set RE5 = CreateObject("VBScript.RegExp") Set RE6 = CreateObject("VBScript.RegExp") '---Oracle変換によりSQLが破壊される場合、当該変換機能のフラグ値を false に設定し、変換を抑止する bTO_CHAR = True bNVL = True bSUBSTR = True bLENGTH = True bSYSDATE = True bTO_NUMBER = True bDECODE = True bCASE = True ' ifutf2asc = SQLText Ora2MsSqlText = "" For i = 1 To Len(SQLText) If WorksheetFunction.Unicode(Mid(SQLText, i, 1)) = 160 Then Ora2MsSqlText = Ora2MsSqlText & " " Else Ora2MsSqlText = Ora2MsSqlText & Mid(SQLText, i, 1) End If Next Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "--.*?(;|\n)", "", True) If (bSYSDATE) Then Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "\bSYSDATE\b", "now()", True) If (bTO_CHAR) Then Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "\bTO_CHAR\s*\(", "str(", True) If (bNVL) Then Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "\bNVL\s*\(([^\,]+),([^\)]+)", "iif($1 is null,$2", True) If (bSUBSTR) Then Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "\bSUBSTR\s*\(", "mid(", True) If (bLENGTH) Then Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "\bLENGTH\s*\(", "len(", True) If (bTO_NUMBER) Then Ora2MsSqlText = RegChg(RE6, Ora2MsSqlText, "\bTO_NUMBER\s*\(", "CInt(", True) If (bCASE) Then Ora2MsSqlText = CONV_CASE_WHEN_CASE_END(Ora2MsSqlText) If (bDECODE) Then Ora2MsSqlText = CONV_DECODE(Ora2MsSqlText) Set REE = Nothing End Function

SQL.bas ※2020/11/27更新

Attribute VB_Name = "SQL" '===ADO,DAO Excel sheet 操作本体 '---・コネクションの確立 Private Function GetXLSConnection(DataSource As String) As Object Dim objCN As Object Dim strCNString As String Set objCN = CreateObject("ADODB.Connection") strCNString = "Provider=Microsoft.ACE.OLEDB.12.0;" _ & "Data Source=" & DataSource & ";" _ & "Extended Properties=""Excel 12.0;HDR=Yes;Readonly=False""" objCN.Open strCNString Set GetXLSConnection = objCN End Function '---・レコードセットの生成(SQL実行) Private Function getRecordset( _ ByRef objCN As Object, _ ByVal strSQL As String, _ ByRef objRS As Object _ ) As Boolean Dim i, ix As Integer Dim n As ADODB.Recordset getRecordset = False On Error GoTo ERR_PROC Set objRS = New ADODB.Recordset objRS.Open strSQL, objCN, 2, 3 i = objRS.RecordCount getRecordset = True Exit Function ERR_PROC: MsgBox "Err=" & Err & " Erl=" & Erl & ":" & strSQL Exit Function End Function '---・コネクションの切断 Private Sub CloseConnection(objCN As Object) If objCN.State <> adStateClosed Then objCN.Close End If Set objCN = Nothing End Sub '---・レコードセット破棄 Private Sub CloseRecordSet(objRS As Object) If objRS.State <> adStateClosed Then objRS.Close End If Set objRS = Nothing End Sub Public Function TBL(ByVal sh As String, nam As String) As String On Error GoTo erp TBL = "[" & sh & "$" & Worksheets(sh).ListObjects(nam).Range.Address(False, False) & "]" Exit Function erp: TBL = "" End Function Public Function NameValue(ByVal sh As String, nam As String) As String On Error GoTo erp adr = Mid(Worksheets(sh).Names(nam), 2) If Len(adr) <= 0 Then Else If Range(adr).Cells(1).NumberFormat = "@" Then NameValue = "'" & Range(adr).Cells(1) & "'" Else NameValue = Range(adr).Cells(1) End If End If Exit Function erp: If Err = 1004 Then NameValue = sh & "%" & nam & " シート " & sh & " に、名前 " & nam & " が定義されていません)" Else NameValue = sh & "%" & nam & " 想定外のエラー" End If Exit Function End Function Public Function Oracle2ExcelSql(Rng As Range) As String Oracle2ExcelSql = ChangeSQLForExcel(Oracle2MsSql(Rng)) End Function '---・SQLの実行・結果展開 Private Sub SQLSelectRange(Rng As Range) Dim objCN As Object Dim objRS As Object Dim strSQL As String Dim lngF As Long Dim FieldName As Variant Dim rowc As Integer Dim n As Variant Dim lastcel As Variant On Error GoTo ERR_PROC strSQL = Oracle2ExcelSql(Rng) Set objCN = GetXLSConnection(ThisWorkbook.FullName) If getRecordset(objCN, strSQL, objRS) = False Then GoTo ERR_PROC End If 100 If ActiveSheet.ListObjects("result").ListRows.Count < 0 Then nrow = Cells.SpecialCells(xlCellTypeLastCell).Row + 2 Else nrow = ActiveSheet.ListObjects("result").Range.Cells(1).Row ActiveSheet.ListObjects("result").Delete End If n = objRS.GetRows ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(nrow, 2), Cells(nrow, objRS.Fields.Count + 1)), , xlYes).Name = "result" For i = 0 To objRS.Fields.Count - 1 ActiveSheet.Cells(nrow, i + 2) = objRS.Fields(i).Name Next For rowc = 0 To UBound(n, 2) ActiveSheet.ListObjects("result").ListRows.Add nrow = nrow + 1 For j = 0 To UBound(n, 1) ActiveSheet.Cells(nrow, j + 2).NumberFormatLocal = "@" ActiveSheet.Cells(nrow, j + 2) = n(j, rowc) Next Next GoTo END_PROC ' Macro1 Macro ' Range("B25:J26").Select Application.CutCopyMode = False Range("J29").Select ERR_PROC: If Erl = 100 Then Resume Next MsgBox "Err=" & Err & " Erl=" & Erl Exit Sub END_PROC: Call CloseRecordSet(objRS) Call CloseConnection(objCN) End Sub Private Function ChangeSQLForExcel(ByVal SQLText As String) As String Dim tbn As String Dim RE0 As Object Set RE0 = CreateObject("VBScript.RegExp") ChangeSQLForExcel = "" 'ExcelテーブルのSQLテーブル指定への変換 ' Debug.Print ActiveSheet.Name Set ret = RegSch(RE0, SQLText, "(([\wぁ-腕]+|)@[\wぁ-腕]+)", True, True) nowpos = 1 For i = 0 To ret.Count - 1 ChangeSQLForExcel = ChangeSQLForExcel & Mid(SQLText, nowpos, ret(i).firstindex - nowpos + 1) n = InStr(ret(i).Value, "@") If n = 1 Then shnn = ActiveSheet.Name Else shnn = Left(ret(i).Value, n - 1) End If tbn = Mid(ret(i).Value, n + 1, Len(ret(i).Value) - 1) realTBL = TBL(shnn, tbn) If Len(realTBL) > 0 Then ChangeSQLForExcel = ChangeSQLForExcel & TBL(shnn, tbn) Else ChangeSQLForExcel = ChangeSQLForExcel & ret(i).Value End If nowpos = ret(i).firstindex + Len(ret(i).Value) + 1 ' Debug.Print ExcelSQL Next i ChangeSQLForExcel = Ora2MsSqlText(ChangeSQLForExcel + Mid(SQLText, nowpos, Len(SQLText) - nowpos + 1)) 'Debug.Print ChangeSQLForExcel 'Excelシート毎名前(バインド変数)のSQLテキスト中で値に変換 ' Debug.Print ActiveSheet.Name SQLText = ChangeSQLForExcel ChangeSQLForExcel = "" Set ret = RegSch(RE0, SQLText, "(([\wぁ-腕]+|)\%[\wぁ-腕]+)", True, True) Set RE0 = Nothing nowpos = 1 ' Debug.Print SQLText For i = 0 To ret.Count - 1 ChangeSQLForExcel = ChangeSQLForExcel & Mid(SQLText, nowpos, ret(i).firstindex - nowpos + 1) n = InStr(ret(i).Value, "%") If n = 1 Then shnn = ActiveSheet.Name Else shnn = Left(ret(i).Value, n - 1) End If tbn = Mid(ret(i).Value, n + 1, Len(ret(i).Value) - 1) realValue = NameValue(shnn, tbn) If Len(realValue) > 0 Then ChangeSQLForExcel = ChangeSQLForExcel & realValue Else ChangeSQLForExcel = ChangeSQLForExcel & ret(i).Value End If nowpos = ret(i).firstindex + Len(ret(i).Value) + 1 ' Debug.Print ExcelSQL Next i ChangeSQLForExcel = Ora2MsSqlText(ChangeSQLForExcel + Mid(SQLText, nowpos, Len(SQLText) - nowpos + 1)) End Function '---SQLの実行（選択されたセル範囲をSQL文として実行） Public Sub SQLSelectSelected() heartbeet ("start") SQLSelectRange (Selection.Areas(1)) heartbeet ("end" & Chr(13) & Chr(13)) End Sub