VBA Oracleで検索、インサートする、更新

検索

Sub searchOracle()
Dim conn As Object
Dim rs As Object
Dim strConn As String
Dim strSql As String
Dim foundCell As Range
Dim table_Name As String
Dim colOffset As Long
Dim retPiont As Range 'スタート　セール
Dim StratTime, StopTime As Variant           '// 処理時間計測用
Dim dataCounts As Integer
Dim dataFilds As Integer
Dim dataRange As Range
Dim tempDATA() As Variant
StartTime = Time
strConn = getstrConn

strSql = ""
table_Name = ""

Call clearOldRET  '古いデータを削除
Call getSql(strSql)  'クエリ文字列を取得

Set conn = CreateObject("ADODB.Connection")
On Error GoTo ErrorHandler2
conn.Open strConn '

Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = 3 ' レコード数を取得するため
rs.Open strSql, conn

'『結果』を載せる位置を取得,
Set retPiont = getStartRange("結果：", 1, 1)

colOffset = 0

'タイトル
 For Each Field In rs.Fields
    retPiont.Offset(0, colOffset).Value = Field.Name
    retPiont.Offset(0, colOffset).EntireColumn.AutoFit
    colOffset = colOffset + 1
 Next Field
 
Set foundCell = ActiveSheet.cells.Find(what:="テーブル名：", LookIn:=xlValues, Lookat:=xlWhole)

If Not foundCell Is Nothing Then
    table_Name = Replace(foundCell.Offset(0, 1).Value, " ", "")
 End If
 
 'データを読み込む
dataCounts = 0

rs.MoveFirst
If rs.EOF Then
      dataCounts = 0
   Else
      rs.MoveLast
      dataCounts = rs.RecordCount
   End If

dataFilds = rs.Fields.Count - 1
 '配列設定
 ReDim tempDATA(dataCounts, dataFilds)
 
 '文字化け防止フォーマット　設定
Set dataRange = Range(retPiont, cells(dataCounts + retPiont.Row + 1, dataFilds + retPiont.Column))
    dataRange.NumberFormatLocal = "@"
    
'データ取得
     rs.MoveFirst
      Dim r, c, j As Long
     r = 0
     Do Until rs.EOF
            For j = 0 To rs.Fields.Count - 1
                
                If IsNull(rs.Fields(j)) Then
                     tempDATA(r, j) = ""
                 Else
                    tempDATA(r, j) = CStr(rs.Fields(j))
                End If
            Next j
         r = r + 1
         rs.MoveNext
    Loop
    'データを取込
    For r = 0 To dataCounts
        For c = 0 To dataFilds
             retPiont.Offset(r + 1, c).Value = tempDATA(r, c)
        Next c
    Next r

StopTime = Time - StartTime
retPiont.Offset(-1, 0) = "所要時間:" & Minute(StopTime) & "分" & Second(StopTime) & "秒"
ErrorHandler2:
    If conn.State = 1 Then
        If rs.State = 0 Then

                Set retPiont = getStartRange("結果：", 1, 1)
                retPiont.Offset(-1, 0) = "SQLは間違い" + Error.Message
                
         Else
            rs.Close
            
        End If
        If Error <> "" Then
            ThisWorkbook.Sheets("クエリLOG").cells.Clear
            ThisWorkbook.Sheets("クエリLOG").cells(1, 1) = Now & vbCrLf & "ExecuteSQL: " & strSql & vbCrLf & Error
        End If
       conn.Close
    
    End If
Set conn = Nothing
End Sub

Sub getSql(ByRef strSql As String) '
Dim strSql2 As String
 '取込クエリ
 '検索目標シート名、検索項目名、目標列番号、遷移値（１：右、-1：左）,戻す文字列
 Call getQureyString("クエリ", ActiveSheet.Name, "A", 1, strSql)
 Dim checkNum As Integer
 
 Dim ws As Worksheet
 Dim dict As Object
 Dim colRange As Range
 Dim cellTarget As Range
 Dim emptyNum As Integer
 Set ws = ActiveSheet
 
 Set colRange = ws.Range("D3", "D200")
 checkNum = 0
 For Each cellTarget In colRange
    If Not IsEmpty(cellTarget) Then
    Dim starPiont
    starPiont = 0
        If InStr(strSql, cellTarget) > 0 Then ' カラム名チェック
        starPiont = InStr(strSql, cellTarget)
            Dim leftcell As Range
            '引数を取得
            Set leftcell = cellTarget.Offset(0, -2)
            'チェック　実行
            checkData leftcell, checkNum
            
            Select Case checkNum
            Case 1
                MsgBox cellTarget.Value & ":引数のタイプが間違い"
                cellTarget.Select
                strSql = ""
                Exit Sub
            Case 2
                MsgBox cellTarget.Value & ":引数の桁数が間違い"
                cellTarget.Select
                strSql = ""
                Exit Sub
            Case 3
                MsgBox cellTarget.Value & ":引数のが必須です"
                cellTarget.Select
                strSql = ""
                Exit Sub
                
            End Select
            strSql = Replace(strSql, vbCrLf, " " & vbCrLf)
            ' 空欄チェック処理
            If leftcell.Value <> "" Then  ' 空欄チェック
                strSql = Replace(strSql, cellTarget.Value, "'" & leftcell.Text & "'")
            Else  ' 空欄チェックの場合は　 IS NOT NUll　を入り替え
                eqpiont = InStrRev(strSql, "=", starPiont)
                midString = Mid(strSql, eqpiont, starPiont - eqpiont) & cellTarget.Value
               strSql = Replace(strSql, midString, " IS NOT NUll")
            End If
        Else
            MsgBox "パラメータ名：" & cellTarget & "が間違いでした。"
            cellTarget.Select
            strSql = ""
            Exit Sub
        End If
    Else
        Exit Sub
    End If
 Next cellTarget
 '取込パラメータ
End Sub

'検索クエリを取得
'文字列により、指定されたシートでセールのアドレスを取得,検索目標シート名、検索項目名、目標列番号、右フラグ（１：右、-1：左）,戻す文字列
Sub getQureyString(ByVal wsheetName As String, ByVal ObjectName As String, ByVal Colms As String, ByVal leftFLG As Integer, ByRef retString As String)
Dim ws As Worksheet
Dim colmRange As Range
Dim foundCells As Range
Set ws = ThisWorkbook.Sheets(wsheetName)
Set colmRange = ws.Columns(Colms)
Set foundCells = colmRange.Find(what:=ObjectName, LookIn:=xlValues, Lookat:=xlWhole)
If Not foundCells Is Nothing Then retString = foundCells.Offset(0, leftFLG)

End Sub

Sub checkData(prmCell As Range, ByRef retNum As Integer)
    Dim typeNme As String
    Dim longth As Integer
    Dim notNull As String
    Dim val
    val = prmCell.Value
     
    typeNme = prmCell.Offset(0, 3)
    longth = CInt(prmCell.Offset(0, 4))
    notNull = prmCell.Offset(0, 5)
    
    If typeNme = "" And longth = 0 And notNull = "" Then
        retNum = 0
    End If
    
    If typeNme <> "" Then
    
        If typeNme = "long" Or typeNme = "int" Or typeNme = "duble" Then
            If Not IsNumeric(val) Then
                retNum = 1
            Else
                retNum = 0
            End If
        ElseIf typeNme = "date" Then
             If Not IsDate(val) Then
                retNum = 1
            Else
                retNum = 0
            End If
            
        Else
            retNum = 0
        End If
    End If
    
    If longth <> 0 Then
        If Len(val) > longth Then
            retNum = 2
        Else
            retNum = 0
        End If
    End If
    
    If notNull = "〇" And prmCell = "" Then
        retNum = 3
    End If
    
End Sub

インサート　実行する

Sub runInsert()
Call insertOracleArray
End Sub

共通メゾット

'DB情報取得
Sub getDBInfo(ByRef DATA_SOURCE As String, ByRef Password As String, ByRef USER_ID As String)
    Dim ws As Worksheet
    Dim foundCell As Range
    
    Set ws = Worksheets("DBInfo")’DB接続文を格納
    inputStr = ActiveSheet.cells(2, 2).Value
    
    Set foundCell = ws.cells.Find(what:=inputStr, LookIn:=xlValues, Lookat:=xlWhole)
    DATA_SOURCE = foundCell.Offset(0, -1) & ":1521/" & foundCell.Offset(1, -1)
    USER_ID = foundCell.Offset(2, -1)
    Password = foundCell.Offset(3, -1)
End Sub
'データベース接続文
Function getstrConn() As String
Dim DATA_SOURCE As String
Dim USER_ID As String
Dim Password As String
    
DATA_SOURCE = Empty

USER_ID = Empty
Password = Empty

'DB情報を取得
Call getDBInfo(DATA_SOURCE, USER_ID, Password)

If DATA_SOURCE = "" Or USER_ID = "" Or Password = "" Then
    MsgBox "DB情報を取得することができません"
    Exit Function
End If

getstrConn = "Driver=" & "{Oracle in Oraclient12home1}" _
                        & ";Dbq=" & DATA_SOURCE _
                        & ";Uid=" & USER_ID _
                        & ";Pwd=" & Password
                        
End Function
 '結果：の位置を探す　古い結果を削除
Sub clearOldRET()
 Dim ws As Worksheet
 Dim starCell As Range
 Dim dataCell As Range
 Set ws = ActiveSheet
Set starCell = getStartRange("結果：", 0, 1)
Set dataCell = starCell.Resize(ws.Rows.Count - starCell.Row + 1, ws.Columns.Count - starCell.Column + 1)
    dataCell.Clear
End Sub

'文字列により、セールのアドレスを取得
Function getStartRange(searchWord As String, top_v As Integer, left_v As Integer) As Range
    Dim ws As Worksheet
    Dim foundCell As Range
    Set ws = ActiveSheet
    Set foundCell = ws.cells.Find(what:=searchWord, LookIn:=xlValues, Lookat:=xlWhole)
   Set getStartRange = foundCell.Offset(top_v, left_v) 'foundCell.Offset(top_v, left_v).Address
End Function

'テープ情報を取得　 targetName: notnull / type　必須/類型
Function getUpdateTableInfo(tableName As String, targetName) As Variant
Dim conn As Object
Dim rs As Object
Dim strConn As String
Dim strSql As String

strConn = getstrConn
strSql = "SELECT " & _
        "  (case " & _
        "    WHEN data_type = 'VARCHAR2' THEN data_type || '(' || nvl(data_precision,data_length) ||')' " & _
        "    WHEN   data_type = 'NUMBER' THEN " & _
        "    data_type || '(' || nvl(data_precision,data_length) || ',' || nvl(data_scale,'0') ||')' " & _
        "    Else data_type " & _
        "    End " & _
        " ) as type " & _
        ", nullable  as notnull " & _
        " FROM " & _
        " user_tab_columns " & _
        " WHERE " & _
        " table_Name =  Replace(Replace( '" & tableName & "',' ',''),'　','')" & _
        " Order by column_id "
Set conn = CreateObject("ADODB.Connection")
conn.Open strConn '
Set rs = CreateObject("ADODB.Recordset")
rs.Open strSql, conn
Dim temp As String
Dim tempArray() As String

Do Until rs.EOF
       temp = temp & rs(targetName) & vbCrLf
        rs.MoveNext
    Loop
temp = Left(temp, Len(temp) - 1)
tempArray() = Split(temp, vbCrLf)
getUpdateTableInfo = tempArray
 
rs.Close
conn.Close
End Function

インサート本体　

'一括インサート　・インサート
Sub insertOracleArray()
Dim conn As Object
Dim cmd As Object
Dim strConn As String
Dim strSql() As String

Dim searchCriteria As String
Dim logCell As Range
Dim logSheet As Worksheet

Call getInsertSql(strSql())

strConn = getstrConn

Set conn = CreateObject("ADODB.Connection")
On Error GoTo ErrorHandler1
conn.Open strConn '

Set logSheet = ThisWorkbook.Sheets("インサートクエリ")
Set logCell = logSheet.cells(1, 1)
logSheet.cells.Clear

For i = LBound(strSql) To UBound(strSql)
     Set cmd = CreateObject("ADODB.Command")
     cmd.ActiveConnection = conn
    
        If strSql(i) <> "" Then
            logSheet.cells(1 + i, 2) = strSql(i)
            cmd.CommandText = strSql(i)
            On Error GoTo ErrorHandler2
            cmd.Execute
        End If
        
ErrorHandler2:
        Errocount = cmd.ActiveConnection.Errors.Count
        If Errocount > 0 Then
            logCell = logCell & cmd.ActiveConnection.Errors(0) & "  " & Now & vbCrLf & "Index: " & i & vbCrLf & "ExecuteSQL: " & strSql(i)
            Set cmd = Nothing
        Else
            logCell = logCell & "処理完了　" & Now & vbCrLf
        End If
        
    Set cmd = Nothing
Next i

ErrorHandler1:
MsgBox "インサート処理　完了"

conn.Close

End Sub


'クエリの配列を取得する
Sub getInsertSql(ByRef strSql() As String)
    Dim ws As Worksheet
    Dim foundCell As Range
    Dim table_Name As String
    Dim startRow As Integer
    Dim startCol As Integer
    Dim lastRow As Integer
    Dim lastCol As Integer
    Dim typeArray() As String
    Dim titleStr As String
    Dim insertStr As String
    Dim insertStrTemp As String
    Set ws = ActiveSheet
    
    Set foundCell = ws.cells.Find(what:="テーブル名：", LookIn:=xlValues, Lookat:=xlWhole)
    table_Name = foundCell.Offset(0, 1).Value
    typeArray = getUpdateTableInfo(table_Name, "type")
    
    Set foundCell = ws.cells.Find(what:="結果：", LookIn:=xlValues, Lookat:=xlWhole)
    startRow = foundCell.Row + 1
    startCol = foundCell.Column + 1
    
    lastRow = ws.cells(ws.Rows.Count, startRow).End(xlUp).Row
    lastCol = ws.cells(startRow, ws.Columns.Count).End(xlToLeft).Column
  
For r = startRow + 1 To lastRow
    Dim sg As String
    Dim date1 As String
    Dim date2 As String
    Dim tempStr As String
    sg = ""
    insertStrTemp = ""
    For j = startCol To lastCol
        If InStr(typeArray(j - startCol), "NUMBER") > 0 Then 'データテープをチェック シングルクォート消し
           sg = ""
        Else
           sg = "'"
        End If
        
        If InStr(typeArray(j - startCol), "DATE") > 0 Then 'データテープをチェック DATE型に変換
           date1 = "TO_DATE("
           date2 = ",'YYYY-MM-DD')"
        Else
           date1 = ""
           date2 = ""
        End If
        If ws.cells(r, j).Value = "" Then
             tempStr = "NULL"
             sg = ""
             date1 = ""
             date2 = ""
        Else
            If InStr(typeArray(j - startCol), "DATE") > 0 Then
                tempStr = Left(ws.cells(r, j).Value, 10)
            Else
                tempStr = ws.cells(r, j).Value
            End If
        End If
    
    insertStrTemp = insertStrTemp & date1 & sg & tempStr & sg & date2 & ","
    Next j
    insertStrTemp = Left(insertStrTemp, Len(insertStrTemp) - 1)
    insertStr = insertStr & "INSERT INTO " & table_Name & " VALUES " & "(" & insertStrTemp & ");" & vbCrLf
Next r
        strSql() = Split(insertStr, vbCrLf)
End Sub

更新

'一括更新　/　更新
Sub updateOracleArray()
Dim conn As Object
Dim cmd As Object
Dim strConn As String
Dim strSql() As String

Dim searchCriteria As String
Dim logCell As Range
Dim logSheet As Worksheet

strConn = getstrConn

Set conn = CreateObject("ADODB.Connection")
On Error GoTo ErrorHandler1
conn.Open strConn '

Call getUpdateSql(strSql())

strConn = getstrConn

Set logSheet = ThisWorkbook.Sheets("インサートクエリ")
Set logCell = logSheet.cells(1, 1)
logSheet.cells.Clear

For i = LBound(strSql) To UBound(strSql)
 logCell.Offset(i, 1) = strSql(i)
 Set cmd = CreateObject("ADODB.Command")
     cmd.ActiveConnection = conn
    
        If strSql(i) <> "" Then
            logSheet.cells(1 + i, 2) = strSql(i)
            cmd.CommandText = strSql(i)
            On Error GoTo ErrorHandler2
            cmd.Execute
        End If
        
ErrorHandler2:
        Errocount = cmd.ActiveConnection.Errors.Count
        If Errocount > 0 Then　'ログ出力
            logCell.Offset(i, 0) = cmd.ActiveConnection.Errors(0) & "  " & Now & vbCrLf & "Index: " & i & vbCrLf & "ExecuteSQL: " & strSql(i)
            Set cmd = Nothing
        Else
            logCell = logCell & "処理完了　" & Now & vbCrLf
        End If
        
    Set cmd = Nothing
Next i

ErrorHandler1:
MsgBox "更新処理　完了"
conn.Close

Call reloadUpdate(strSql())

End Sub

'クエリの配列を取得する
Sub getUpdateSql(ByRef strSql() As String)
    Dim ws As Worksheet
    Dim foundCell As Range
    Dim table_Name As String
    Dim startRow As Integer
    Dim startCol As Integer
    Dim lastRow As Integer
    Dim lastCol As Integer
    Dim typeArray() As String
    Dim titleStrArray() As String
    Dim titleStr As String
    Dim updateStr As String
    Dim updateStrTemp As String
    Dim notNullArray() As String
    Dim updateWhereStr As String
    updateWhereStr = " WHERE "
    Set ws = ActiveSheet
    
    Set foundCell = ws.cells.Find(what:="テーブル名：", LookIn:=xlValues, Lookat:=xlWhole)
    table_Name = foundCell.Offset(0, 1).Value
    typeArray = getUpdateTableInfo(table_Name, "type")
    notNullArray = getUpdateTableInfo(table_Name, "notnull")
    
    Set foundCell = ws.cells.Find(what:="結果：", LookIn:=xlValues, Lookat:=xlWhole)
    startRow = foundCell.Row + 1
    startCol = foundCell.Column + 1
    
    lastRow = ws.cells(ws.Rows.Count, startRow).End(xlUp).Row
    lastCol = ws.cells(startRow, ws.Columns.Count).End(xlToLeft).Column
  
    For i = startCol To lastCol
        titleStr = titleStr + ws.cells(startRow, i) & ","
    Next i
    titleStrArray() = Split(titleStr, ",")
    
For r = startRow + 1 To lastRow
    Dim sg As String
    Dim date1 As String
    Dim date2 As String
    Dim tempStr As String
    sg = ""
    updateStrTemp = ""
    updateWhereStr = " WHERE "
    For j = startCol To lastCol
        
        If InStr(typeArray(j - startCol), "NUMBER") > 0 Then 'データテープをチェック シングルクォート消し
           sg = ""
        Else
           sg = "'"
        End If
        
        If InStr(typeArray(j - startCol), "DATE") > 0 Then 'データテープをチェック DATE型に変換
           date1 = "TO_DATE("
           date2 = ",'YYYY-MM-DD')"
        Else
           date1 = ""
           date2 = ""
        End If
        
        If ws.cells(r, j).Value = "" Or ws.cells(r, j).Value = "NULL" Then
             tempStr = "NULL"
             sg = ""
             date1 = ""
             date2 = ""
        Else
            If InStr(typeArray(j - startCol), "DATE") > 0 Then
                tempStr = Left(ws.cells(r, j).Value, 10)
            Else
                tempStr = ws.cells(r, j).Value
            End If
        End If
        
        If notNullArray(j - startCol) = "N" Then 'データNotNullを条件文字列に追加
           updateWhereStr = updateWhereStr & " " & titleStrArray(j - startCol) & " = " _
           & date1 & sg & tempStr & sg & date2 & " AND "
        End If
    
    updateStrTemp = updateStrTemp & " " & titleStrArray(j - startCol) & " = " & date1 & sg & tempStr & sg & date2 & ","
    Next j
    updateWhereStr = Left(updateWhereStr, Len(updateWhereStr) - 5) '最後の’　AND　’消し
    updateStrTemp = Left(updateStrTemp, Len(updateStrTemp) - 1)  '最後の’，’消し
    updateStr = updateStr & " UPDATE " & table_Name & " SET " & updateStrTemp & updateWhereStr & ";" & vbCrLf
Next r
        strSql() = Split(updateStr, vbCrLf)
End Sub
'更新後再表示
Sub reloadUpdate(sqlArray() As String)
Dim ws As Worksheet
Dim conn As Object
Dim rs As Object
Dim strConn As String
Dim strSql As String
Dim foundCell As Range
Dim colOffset As Long
Dim retPiont As Range 'スタート　セール

Set ws = ActiveSheet
Set foundCell = ws.cells.Find(what:="テーブル名：", LookIn:=xlValues, Lookat:=xlWhole)
    table_Name = foundCell.Offset(0, 1).Value
    
'『結果』を載せる位置を取得,
Set retPiont = getStartRange("結果：", 1, 1)

strConn = getstrConn
Set conn = CreateObject("ADODB.Connection")
On Error GoTo ErrorHandler1
conn.Open strConn '

For i = LBound(sqlArray) To UBound(sqlArray)
    If sqlArray(i) <> "" Then
        Dim whereWordNum As Long
        whereWordNum = InStr(sqlArray(i), " WHERE ")'SELECTクエリを作成、UPDATEの条件をコピー
        strSql = " SELECT * FROM " & table_Name & " " & Right(sqlArray(i), Len(sqlArray(i)) - whereWordNum)
        Set rs = CreateObject("ADODB.Recordset")
        On Error GoTo ErrorHandler1
        rs.Open strSql, conn
        '更新後データを読み込む
       rs.MoveFirst
       
       Do Until rs.EOF
            For j = 0 To rs.Fields.Count - 1
                If Len(rs.Fields(j)) > 14 And IsNumeric(rs.Fields(j)) Then
                    retPiont.Offset(i + 1, j).Value = CStr(rs.Fields(j))
                Else
                    retPiont.Offset(i + 1, j).Value = rs.Fields(j)
                End If
            Next
            rs.MoveNext
       Loop
       'retPiont.Offset(i + 1, 0).CopyFromRecordset rs
       retPiont.Offset(i + 1, 0).Select
       rs.Close
       
ErrorHandler2:
            Errocount = rs.ActiveConnection.Errors.Count
            If Errocount > 0 Then
                rs.Close
            End If
    End If
      
Next i

ErrorHandler1:
If conn.State = 1 Then
   If rs.State = 0 Then
        retPiont.Offset(-1, 0) = "更新後の表示Lは間違い"
    Else
    rs.Close
   End If
   conn.Close
End If

Set conn = Nothing

End Sub

一括削除・削除

Sub oracle_delete()

Dim strSqlArray() As String

Dim conn As Object
Dim cmd As Object
Dim strConn As String
Dim strSql As String
Dim searchCriteria As String
Dim logCell As Range
Dim logSheet As Worksheet

strConn = getstrConn

Set conn = CreateObject("ADODB.Connection")
On Error GoTo ErrorHandler1
conn.Open strConn '

Set logSheet = ThisWorkbook.Sheets("インサートクエリ")
Set logCell = logSheet.cells(1, 1)
logSheet.cells.Clear

StartTime = Time
strConn = getstrConn

strSql = ""
table_Name = ""

Call clearOldRET  '古いデータを削除
Call getSql(strSql)  'クエリ文字列を取得

Set conn = CreateObject("ADODB.Connection")
On Error GoTo ErrorHandler2
conn.Open strConn '

strSqlArray() = Split(strSql, ";")

For i = LBound(strSqlArray) To UBound(strSqlArray)
     Set cmd = CreateObject("ADODB.Command")
     cmd.ActiveConnection = conn
    
        If strSqlArray(i) <> "" Then
            logSheet.cells(1 + i, 2) = strSqlArray(i)
            cmd.CommandText = strSqlArray(i)
            On Error GoTo ErrorHandler2
            cmd.Execute
        End If
        
ErrorHandler2:
        Errocount = cmd.ActiveConnection.Errors.Count
        If Errocount > 0 Then
            logCell = logCell & cmd.ActiveConnection.Errors(0) & "  " & Now & vbCrLf & "Index: " & i & vbCrLf & "ExecuteSQL: " & strSqlArray(i)
            Set cmd = Nothing
        Else
            logCell = logCell & "処理完了　" & Now & vbCrLf
        End If
        
    Set cmd = Nothing
Next i

ErrorHandler1:
MsgBox "削除処理　完了"

conn.Close


End Sub

完了