VBA : SQLSelectSelected : 改修 : Select 結果を result という名のExcel テーブルに出力

ココで最新版を公開している、自画自賛 DB 不要 SQL 実行環境 ”SQLSelectSelected” であるが、また、ちょい改修をいれたぞ。

Select 結果が展開される表組を Excelテーブルに作り込む様に修正した。

初回 Select 時はシート有効データの最後に追加しているが、これをExcelテーブルにして、２回目からは、同じ場所を上書きするように修正した。

resultt テーブルを cut & paste で移動すれば、以降の Select 実行でも、移動先の result テーブルを上書きする。

このツール、マジ凄くね？ 

日本では著作権を放棄できないので著作権自体は保持するが、業務利用も含めて使用権は制限なしだ。 SQLデバッグで泣いてるおまいら、このツールで応援するぞ。再販は認めん。

動作環境を確認したが、現時点で最新OSの windows10(64bit) + 自腹で買ったExcel2019 で開発した。 CPUはAtomだ笑え。

Microsoft Access Database Engine 2016 Redistributable をインストールすれば、なんと windows8(32bit) + Excel2013 でも完璧に動いたぞ。 Lenovo MiiX とかいう 7inch の Atom タブレットだ。大いに笑え。

おまいらの Core i プロセッサなら問題ないはず。 早く SQLデバッグを終わらせて、皆で「星を紡ぐ子供たち」 にハマろう。フレンド申請受付中だぞ。

VBA : SQLSelectSelected で使用した関数のインターフェース仕様。ワークシート関数として使用可だ。

 前記事で公開した SqlSelectSelected とともに作成された、外部使用可能な関数のインターフェース仕様だ。

変換後SQLの検証、Oracleコンバートの一次変換に使ってくれ。

VBAで作成された Public Function をワークシート関数に使用すると、シート再描画が激遅だ。

concatsep以外の関数、Oracle2MsSql、Oracle2ExcelSqlはブック中での多用回避に留意しろし。

concatsep  汎用関数として使用可

Oracle2MsSqlText  他の自作マクロ等から呼出し可

Oracle2MsSql  Oracle⇒Access(SQLServer)変換の一次加工に使用可

Oracle2ExcelSql  SQLSelectSelectedマクロエラー時のSQL文法チェックに使用

Function concatsep(<セル範囲>[,[<列間セパレータ>][,<行間セパレータ>]]) as string

セル範囲の値をテキストとして結合する

列間、行間セパレータの省略値はセル内改行コード”chr(10)" になる

SQLテキストの場合、列間セパレータを半角スペース、行間セパレータを chr(10) に設定する

例. =concatsep(C13:G23," ",CHAR(10))

Function Oracle2MsSqlText(<SQL文字列>) as string

Oracle用のSQL文をAccess用のSQL文に変換する

(よく使われ、変換が比較的簡単なOracle方言のみ)

例. =Oracle2MsSqlText("select * from TABLE1")

Function Oracle2MsSql(<セル範囲>) as string

セル範囲に記載された、Oracle用のSQL文をAccess用のSQL文に変換する

内部でconcatsep,Oracle2MsSqlTextを呼び出している

例. =Oracle2MsSQL(C13:G23)

Function Oracle2ExcelSql(<セル範囲>) as string

セル範囲に記載された、Oracle用のSQL文を、SQLSelectSelectedマクロが使用するExcel用のSQL文に変換する

内部でOracle2MsSqlを呼び出している

例. =Oracle2ExcelSql(C13:G23)

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  

SQLSelectSelectedマクロ動作検証（操作方法）

さて、前記事で公開したSQLSelectSelectedマクロだが、表結合の動作検証もかねて、実際の操作手順を解説するぞ。

手抜き資料なので、見辛さは堪忍してくれ。

初心者向けにSQLを解説しているサイトの、例題表組、SQLをそのままコピペでwebから持ってきて、同一結果がでる事を確認している。

白羽の矢が立ったサイトはココだ、Mochizukiさん、勝手に使って申し訳ない。

①web上から例題の表組を任意ワークブックの任意の場所に張り付ける

	dogsテーブル				ownersテーブル
	b	c	d	e	f	g
5	id	name	owner_id		id	name
6	1	aka	1		1	ichiro
7	2	ao	2		2	jiro
8	3	shiro	1		3	saburo
9	4	kuro	4

②れぞれ表組範囲を選択しCTRL+Tを押下しExcelテーブルとする。※表組範囲の選択は、ヘッダ行も含めて選択する

③テーブル領域のいずれかのセルを選択すると、Excelメニューに「デザイン」のタブが現れる

左端の「テーブル名」に、SQLで使用するテーブル名称を入力する

④同webからSQLをテーブルを設定したシートの任意セルに貼り付ける

SELECT * FROM dogs
INNER JOIN owners
ON dogs.owner_id = owners.id;

⑤本マクロの仕様に合わせ、テーブル名部分全てに"@"を付加する

SELECT * FROM @dogs
INNER JOIN @owners
ON @dogs.owner_id = @owners.id;

⑥⑤のSQLテキストセルを選択した状態で、SQLSelectSelectedマクロを実行

SELECT * FROM [Sheet2$B5:D9] INNER JOIN [Sheet2$F5:G8] ON [Sheet2$B5:D9].owner_id = [Sheet2$F5:G8].id;

※⑤のSQLは左記SQLに、内部で変換され実行される

⑦SQLを実行したワークシートデータ有効最下行にSelect結果が展開される

※展開されたSelect結果中の項目名がテーブル名で修飾される場合、Excel参照形式の表記になる。

⑧項目名がみっともないので、テーブル名をasで別名定義し、オリジナルのSQLと同じ表題にする

SELECT * FROM @dogs as dogs
INNER JOIN @owners as owners
ON dogs.owner_id = owners.id;

⑨⑧のSQLテキストセルを選択した状態で、SQLSelectSelectedマクロを実行する

⑩SQLを実行したワークシートデータ有効最下行にSelect結果が展開される

⑪同様にLEFT OUTER JOIN サンプルを実行

SELECT * FROM @dogs as dogs
LEFT OUTER JOIN @owners as owners
ON dogs.owner_id = owners.id;

⑫同様にLEFT OUTER JOIN サンプルを実行

SELECT * FROM @dogs as dogs
RIGHT OUTER JOIN @owners as owners ON dogs.owner_id = owners.id;

VBA : SQLSelectSelectedマクロ : DB無しEXCELのみで SQL 単体実行ができちゃう君

最新版はこちら

Excel単独で、SQL実行環境を作ってみた。設計段階でのSQL検証や、SQL研修、SQL単体試験での出力想定値算出等に使ってくれ。もう一度言うが、Excel単独で、DBサーバ、DBクライアントは一切必要ない。

実行できるのはSelect文のみだ。Access用のSQLであれば動作するがデータソースがEXCELなので、インデックス、NULL禁止項目、データ型、項目長の定義ができない。依存するSQLはNGだ。JOIN,GROUP HAVING,EXISTS 等、問題なしで動くぞ。

また、前記事のOracle→AccessSQL変換を呼び出しているが、CASE,DECODEがあると激遅になるので注意しろし。OracleSQL変換で失敗するとSQLが空になるので、Oracle2MsSQL

ワークシート関数で、変換結果を確認してくれ。

ソースコードに "SQL.bas" とか名前を付け保存し、XLSM(マクロ対応ワークブック)のVBAエディタからインポートしてくれ。前の記事の"OR2MSSQL.bas" もインポートし、参照設定で”Microsoft ActiveX Data Objects 6.1 Library"を参照してくれ。

Accessの再配布ライブラリを導入 or データコネクションで Jetエンジンを指定すればExcel2013でも動くらしいぞ。もちろん2013は未検証だ。

最新版はこちら

VBA : Oracle2MsSQL : Oracle⇒Access SQL変換ワークシート関数

300ステップに近い大物マクロだぞ。

セル範囲をパラメタにして、変換結果を返す関数だ。

「なんちゃって変換」なので、変換できない文もあるぞ。

変換作業の一次変換だと割り切って使ってくれ。

以下のOracle関数、Oracle文に対応している。

SUBSTR ⇒ mid

LENGTH ⇒ len

SYSDATE ⇒ now

TO_NUMBER ⇒ CInt

  単純置換。

TO_CHAR ⇒ str

  数値から文字への変換のみ対応。日付のTO_CHARはNG

NVL ⇒  iif

  iif関数にパラメタ追加し変換

  

DECODE ⇒ iif

  iif関数の入れ子に変換

  

CASE ⇒ iif

  iif関数の入れ子に変換

  "CASE WHEN xxx=yyy" , "CASE xxx WHEN yyy" 両方に対応。

  CASE文の入れ子も変換できるが、そもそもそんな汚いSQL書くなし。

いずれかの変換で誤変換される場合、内部関数、Ora2MsSqlText中にフラグがあるので、false立てて機能を切ってくれ。

Macroのつぼ

「VBAのバグじゃね？」と、思わずヒイたぞ。

例えば、For i = 10 to 0 Step -1 のループ中で、添え字"i"を11に変えてループ継続させてみた。

※ループ中特定条件で、ループを最初からやり直す処理だな。

ループのNext前処理として、Step -1 が実行され、i=10で実行されるところ、i=11のままだった。

※2020/11/20 最適化したので、ループ添え字書き換えロジックは排除された

 

Forループの中で、脱出条件やループ添え字を変えるような、汚いことはするなというMSのお達しだ。

当該処理にはdo,while,until,loopを使えし。CASE文の変換はOSのメモリ状態次第で、数秒～数十秒掛かる場合があるぞ。

１ブックにこの関数を多用すると再描画でもどってこないから気を付けろし。

ソースコードに "OR2MSSQL.bas" とか名前を付け保存し、XLMS(マクロ対応ワークブック)のVBAエディタからインポートしてくれ。

※2020/11/19 最適化の為一部修正　

Attribute VB_Name = "Ora2MsSQL" '---・SQL文のExcel用SQLへの変換(表示確認用) Public Function Oracle2MsSql(Rng As Range) As String Oracle2MsSql = Ora2MsSqlText(ConcatSep(Rng, " " & vbLf)) End Function '===汎用共通関数 '---正規表現検索 Public Function RegSch(strTarget As String, strPat As String, Optional IgnoreCase As Boolean = True, Optional bGlobal As Boolean = False) As Object Dim RE As Object Set REE = CreateObject("VBScript.RegExp") With REE .Pattern = strPat .IgnoreCase = IgnoreCase .Global = bGlobal .MultiLine = True End With Set RegSch = REE.Execute(strTarget) Set REE = Nothing End Function '---正規表現置換 Public Function RegChg(strTarget As String, strPat As String, para As String, Optional Ignore As Boolean = True) As String Dim Match, Matches Dim ret As String Set RE = CreateObject("VBScript.RegExp") With RE .Pattern = strPat .IgnoreCase = Ignore .Global = True End With RegChg = RE.Replace(strTarget, para) Set RE = Nothing End Function '---セル内容結合関数 'セル範囲のテキストを、セル内改行をセパレータにして１テキストに結合するため Public Function ConcatSep(Rng As Range, Optional sep As String = vbLf) As String ConcatSep = "" Dim nSelCount As Integer nSelCount = Rng.Cells.Count For Each cel In Rng.Cells ConcatSep = ConcatSep & cel.Value nSelCount = nSelCount - 1 If (nSelCount > 0) Then ConcatSep = ConcatSep & sep 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(str1, "[ ]+", " ") Set ret3 = RegSch(str1, "\bCASE (.*?) WHEN", True, True) ifword = ret3(0).submatches(0) Set ret2 = RegSch(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(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(str1, "[ ]+", " ") Set ret2 = RegSch(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(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(ConvSQLText, "\bCASE\b", True, True) 'end case出現箇所抽出 Set ret2 = RegSch(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 For i = ret.Count - 1 To 0 Step -1 bAboid = False 'end case出現箇所(全)と case出現箇所出現箇所を比較 For j = 0 To ret2.Count - 1 pos = ret2(j).firstindex + Len(ret2(j).Value) - 4 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(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(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 'case出現箇所抽出 ' Set ret = RegSch(ConvSQLText, "\bCASE\b", True, True) 'end case出現箇所抽出 Set ret2 = RegSch(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(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(ByVal SQLText As String) As String Dim ret As Object Dim shnn, tbn As String 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(ifutf2asc) If WorksheetFunction.Unicode(Mid(ifutf2asc, i, 1)) = 160 Then Ora2MsSqlText = Ora2MsSqlText & " " Else Ora2MsSqlText = Ora2MsSqlText & Mid(ifutf2asc, i, 1) End If Next Ora2MsSqlText = RegChg(Ora2MsSqlText, "--.*?(;|\n)", "", True) If (bSYSDATE) Then Ora2MsSqlText = RegChg(Ora2MsSqlText, "\bSYSDATE\b", "now()", True) If (bTO_CHAR) Then Ora2MsSqlText = RegChg(Ora2MsSqlText, "\bTO_CHAR\s*\(", "str(", True) If (bNVL) Then Ora2MsSqlText = RegChg(Ora2MsSqlText, "\bNVL\s*\(([^\,]+),([^\)]+)", "iif($1 is null,$2, $1", True) If (bSUBSTR) Then Ora2MsSqlText = RegChg(Ora2MsSqlText, "\bSUBSTR\s*\(", "mid(", True) If (bLENGTH) Then Ora2MsSqlText = RegChg(Ora2MsSqlText, "\bLENGTH\s*\(", "len(", True) If (bTO_NUMBER) Then Ora2MsSqlText = RegChg(Ora2MsSqlText, "\bTO_NUMBER\s*\(", "CInt(", True) If (bCASE) Then Ora2MsSqlText = CONV_CASE_WHEN_CASE_END(Ora2MsSqlText) If (bDECODE) Then Ora2MsSqlText = CONV_DECODE(Ora2MsSqlText) End Function  

VBA : ConcatSep : セパレータ指定セル範囲文字列結合ワークシート関数

指定されたセル範囲のValueを文字列として結合するワークシート関数だ。

他マクロからの呼び出しやワークシート関数として使える。

結合時のセパレータを指定できるが、セパレータ指定を省略した場合、LF(セル内改行)をセパレータとして結合する。ただし、結合結果末尾にはセパレータは付加されない

使い方

=ConcatSep(<セル範囲>,[<セパレータ文字列>])

第二パラメタは省略可でディフォルト値はvbLF(セル内改行)となる

ex.

Macroのつぼ

ペーストされたテキストデータ等を1テキストに変換する。

本関数に限らずワークシート関数をVBAで作成すると、再描画時が致命的に遅くなる場合がある。

アドイン(.xla、.xlam)で作った方がイイと思う。

Function ConcatSep(rng As Range, Optional sep As String = vbLf) As String ConcatSep = "" Dim nSelCount As Integer nSelCount = rng.Cells.Count For Each cel In rng.Cells ConcatSep = ConcatSep & cel.Value nSelCount = nSelCount - 1 If (nSelCount > 0) Then ConcatSep = ConcatSep & sep End If Next End Function  

VBA : RegChg : 正規表現置換ワークシート関数

ぶっちゃけ、何年ぶりの更新よ！？

他マクロからの呼び出しやワークシート関数として使える。

ソース文字列（orセル）の中でマッチした正規表現パターンを、置換文字列に置き換える。部分文字列も使えるし、大文字小文字Case指定も出来る。

使い方

=RegChg(<検索対象>,<正規表現パターン>,<"置換パターン>,[IgnoreCase:true/false])

第四パラメタは省略可でディフォルト値はtrue。IgnoreCaseとなる

ex.
=RegChg("TestType of File1,"T","tt")
=RegChg("TestType of File1,"T","tt",true)
   戻り値は""ttesttttype of File1"

=RegChg("TestType of File1"Test(.*)File([0-9]+)","$1$2")
   戻り値は""Type of 1"

Macroのつぼ

WSH等で使われるComモジュールのRegExpをEｘcelから呼び出している。

マクロ作るのメンドーで、ワークシート関数でナントカしたいヤシ、そのまま使ってくれ。アドイン(.xla)で作った方がイイと思う。

指定セル範囲を直接置換する機能も公開予定だ。

Function RegChg(strTarget As String, strPat As String, para As String, Optional Ignore As Boolean = True) As String Dim Match, Matches Dim ret As String Set RE = CreateObject("VBScript.RegExp") With RE .Pattern = strPat .IgnoreCase = Ignore .Global = True End With RegChg = RE.Replace(strTarget, para) Set RE = Nothing End Function