だめんずAWK'er (the men's awker): 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

だめんずAWK'er (the men's awker)

はじめに

2020年11月18日水曜日

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

0 件のコメント:

コメントを投稿