VBA对DB操作方法范例.doc

反映：Option Explicit- 接続先設定-Private Sub cmdConnect_Click() frmPass.Show vbModalEnd Sub-Private Sub cmdExec_Click() Dim i, j As Long Dim sWorksheetNm As String 反映名 Dim objSheet As Object 処理対象 Dim objCopy As Object 対象 Dim objLastSheet As Object 最終 Dim lRowCount As Long 数 Dim bSheetCKFlg As Boolean Dim lSetCnt As Long 名設定 Dim vRet As Long 戻値 Dim objRecset As OraDynaset Dim myDictionary As Object Dim iMsgRet As Integer Dim sSortKey As String Dim lCreateSheetsF As Long Dim lMultiFlg As Long Dim sTableName(9) As String On Error GoTo ERR_SUB Application.ScreenUpdating = False 更新件数取得 gsMAX_RECORD = ThisWorkbook.Worksheets(接続文字列).Range(B4).Value - 反映 - 生成 Set objSheet = ThisWorkbook.Worksheets(反映) LCH ADD 番号取得 order_NUM = Trim(objSheet.Range(H6).Value) 必須項目 If order_NUM = Then MsgBox 番号入力下。 GoTo EXIT_SUB End If 必須項目 If Trim(objSheet.Range(C25).Value) = Then MsgBox 取込入力下。 GoTo EXIT_SUB End If lMultiFlg = 0 If Trim(objSheet.Range(D25).Value) Then sTableName(0) = Trim(objSheet.Range(C25).Value) sTableName(1) = Trim(objSheet.Range(D25).Value) sTableName(2) = Trim(objSheet.Range(E25).Value) sTableName(3) = Trim(objSheet.Range(F25).Value) sTableName(4) = Trim(objSheet.Range(G25).Value) sTableName(5) = Trim(objSheet.Range(H25).Value) sTableName(6) = Trim(objSheet.Range(I25).Value) sTableName(7) = Trim(objSheet.Range(J25).Value) sTableName(8) = Trim(objSheet.Range(K25).Value) sTableName(9) = Trim(objSheet.Range(L25).Value) lMultiFlg = 1 Else 反映名取得 sWorksheetNm = Trim(objSheet.Range(C25).Value) sTableName(0) = Trim(objSheet.Range(C25).Value) End If 解放 Set objSheet = Nothing If lMultiFlg = 0 Then （存在場合作成） lCreateSheetsF = 0 If chkSheet(sWorksheetNm) = True Then iMsgRet = MsgBox(既存在。新規作成宜？, vbQuestion + vbYesNoCancel) If iMsgRet = vbYes Then 生成 With ThisWorkbook Application.DisplayAlerts = False .Worksheets(sWorksheetNm).Delete Application.DisplayAlerts = True End With ElseIf iMsgRet = vbNo Then lCreateSheetsF = 1 Else Exit Sub End If End If Else iMsgRet = MsgBox(複数読込、宜？, vbQuestion + vbYesNo) If iMsgRet = vbYes Then Else Exit Sub End If End If DB接続 vRet = DBConnect() Select Case vRet Case -1 MsgBox DB接続 GoTo EXIT_SUB Case -2 MsgBox 接続文字列 GoTo EXIT_SUB End Select - 原紙 - For i = 0 To UBound(sTableName) If Trim(sTableName(i) Then If chkSheet(sTableName(i) = False Then 生成 Set objCopy = ThisWorkbook.Worksheets(原紙) objCopy.Visible = True 最終取得 With ThisWorkbook Set objLastSheet = .Worksheets(.Worksheets(.Worksheets.Count).Name) End With 作成 objCopy.Copy After:=objLastSheet Set objLastSheet = Nothing 解放 objCopy.Visible = False Set objCopy = Nothing 名設定 ThisWorkbook.ActiveSheet.Name = sTableName(i) End If - 作成反映 - 生成 Set objCopy = ThisWorkbook.Worksheets(sTableName(i) - 設定 - 名 objCopy.Range(B1).Value = sTableName(i) 取得 vRet = getDBInfo(sTableName(i), objRecset, myDictionary) If vRet 0 Then GoTo EXIT_SUB End If If objRecset.RecordCount 65536 Then MsgBox 件数、65536件以上。条件絞検索下。 GoTo EXIT_SUB End If objCopy.Range(objCopy.Cells(5, 2), objCopy.Cells(gsMAX_RECORD, objRecset.Fields.Count + 3).ClearContents 表示 lSetCnt = 3 objCopy.Activate For j = 0 To objRecset.Fields.Count - 1 PK If myDictionary.Exists(CStr(objRecset.Fields(j).Name) = True Then objCopy.Cells(1, lSetCnt).Value = PK End If objCopy.Cells(2, lSetCnt).Value = objRecset.Fields(j).Name 名 objCopy.Cells(3, lSetCnt).Value = objRecset.Fields(j).Name 名 objCopy.Cells(4, lSetCnt).Value = ConvType(objRecset.Fields(j).OraIDataType) lSetCnt = lSetCnt + 1 Next j 表示 vRet = DispData(objCopy, objRecset) Set objRecset = Nothing Set objCopy = Nothing End If Next i Call DBClose ThisWorkbook.Worksheets(sTableName(0).Activate Application.ScreenUpdating = True Exit SubERR_SUB: MsgBox Err.Number & : & Err.Description EXIT_SUB: Application.ScreenUpdating = True DB切断 Call DBCloseEnd SubPrivate Function chkSheet(ByVal sSheetsName As String) As Boolean Dim i As Long 反映存在 With ThisWorkbook chkSheet = False For i = 1 To .Worksheets.Count If .Worksheets(i).Name = sSheetsName Then chkSheet = True Exit For End If Next i End WithEnd FunctionPrivate Sub cmdGetInfo_Click() Dim i, j As Long Dim sSQL As String SQL文 Dim objSheet As Object 処理対象 Dim objCopy As Object 対象 Dim objLastSheet As Object 最終 Dim lRowCount As Long 数 Dim bSheetCKFlg As Boolean Dim lSetCnt As Long 名設定 Dim vRet As Long 戻値 Dim objRecset As OraDynaset Dim myDictionary As Object Dim iMsgRet As Integer Dim sSortKey As String Dim sInterfaceId As String ID On Error GoTo ERR_SUB Application.ScreenUpdating = False 生成 Set objSheet = ThisWorkbook.Worksheets(反映) DB接続 vRet = DBConnect_Com() Select Case vRet Case -1 MsgBox DB接続 GoTo EXIT_SUB Case -2 MsgBox 接続文字列 GoTo EXIT_SUB End Select 基本情報取得 If Trim(objSheet.Cells(6, 3) Then sInterfaceId = Split(Trim(objSheet.Cells(6, 3), ：)(0) Else sInterfaceId = End If sSQL = SELECT IF_TABLE_NAME FROM TB_BLS_META_INFO WHERE INTERFACE_ID = & sInterfaceId & GROUP BY IF_TABLE_NAME vRet = SelectData(sSQL, objRecset) If vRet 0 Then GoTo ERR_SUB End If If vRet 0 Then GoTo EXIT_SUB End If If objRecset.RecordCount 10 Then MsgBox 件数、10件以上。確認下。 GoTo EXIT_SUB End If 初期化 For i = 3 To 12 objSheet.Cells(25, i) = objSheet.Cells(41, i) = Next i For j = 0 To objRecset.RecordCount - 1 objSheet.Cells(25, j + 3) = objRecset.Fields(objRecset.Fields(0).Name) objSheet.Cells(41, j + 3) = objSheet.Cells(25, j + 3) objRecset.MoveNext Next j Set objRecset = Nothing Set objSheet = Nothing Call DBClose Application.ScreenUpdating = True Exit SubERR_SUB: MsgBox Err.Number & : & Err.Description EXIT_SUB: Application.ScreenUpdating = True DB切断 Call DBCloseEnd SubPrivate Sub cmdSQL_Click() Dim i, j As Long Dim objExcel As Object Excel Dim sITEM_SQL As String INSERTSQL（ITEM部分） Dim sVALUE_SQL As String INSERTSQL（VALUE部分） Dim sMAIN_SQL As String INSERTSQL（結合） Dim lColCnt As Long 作成 Dim sFilePath As String 出力 Dim objFs As Object Dim objFile As Object Dim sTitle As String Dim vRet As Long Dim sDELETSQL As String Dim sDelWhere As String Dim sUPDATESQL As String Dim sUpdWhere As String Dim objRegData As Object 登録済 Dim myDictionary As Object Dim objRecset As OraDynaset Dim objSheet As Object 処理対象 Dim lUpCnt As Long DB接続 vRet = DBConnect() Select Case vRet Case -1 MsgBox DB接続 Exit Sub Case -2 MsgBox 接続文字列 Exit Sub End Select Call DBBeginTrans 番号取得 order_NUM = Trim(ThisWorkbook.Worksheets(反映).Range(H6).Value) 更新件数取得 gsMAX_RECORD = ThisWorkbook.Worksheets(接続文字列).Range(B4).Value Set objRegData = CreateObject(Scripting.Dictionary) lUpCnt = 0 存在分作成。 With ThisWorkbook For i = 1 To .Worksheets.Count 登録指定場合指定登録。 If Trim(.Worksheets(反映).Range(C41).Value) Or _ Trim(.Worksheets(反映).Range(D41).Value) Or _ Trim(.Worksheets(反映).Range(E41).Value) Or _ Trim(.Worksheets(反映).Range(F41).Value) Or _ Trim(.Worksheets(反映).Range(G41).Value) Or _ Trim(.Worksheets(反映).Range(H41).Value) Or _ Trim(.Worksheets(反映).Range(I41).Value) Or _ Trim(.Worksheets(反映).Range(J41).Value) Or _ Trim(.Worksheets(反映).Range(K41).Value) Or _ Trim(.Worksheets(反映).Range(L41).Value) Then If Trim(.Worksheets(反映).Range(C41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(D41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(E41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(F41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(G41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(H41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(I41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(J41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(K41).Value) .Worksheets(i).Name And _ Trim(.Worksheets(反映).Range(L41).Value) .Worksheets(i).Name Then GoTo NO_DATA End If End If 対象生成 Set objExcel = .Worksheets(.Worksheets(i).Name) 処理 If Trim(objExcel.Cells(3, 2).Value) Then vRet = ExecuteData(delete from & Trim(objExcel.Cells(1, 2).Value) & where ORD_NUM = & order_NUM & ) If vRet 0 Then GoTo ERR_DB End If End If If objExcel.Cells(Rows.Count, 2).End(xlUp).Row - 5 2499 Then sITEM_SQL = sITEM_SQL & vbCrLf End If If sITEM_SQL = Then sITEM_SQL = objExcel.Cells(3, 3 + lColCnt).Value Else sITEM_SQL = sITEM_SQL & , & objExcel.Cells(3, 3 + lColCnt).Value End If lColCnt = lColCnt + 1 Loop 部分 For j = 5 To gsMAX_RECORD 入力部分 If Trim(objExcel.Cells(j, 2).Value) Then If Trim(objExcel.Cells(j, 2).Value) D Then lColCnt = 0 sVALUE_SQL = Do If Trim(objExcel.Cells(3, 3 + lColCnt).Value) = Then Exit Do If sVALUE_SQL Then sVALUE_SQL = sVALUE_SQL & , End If 桁数 If Len(sVALUE_SQL) 2400 Then sVALUE_SQL = sVALUE_SQL & vbCrLf End If 生成 Select Case UCase(Trim(objExcel.Cells(4, 3 + lColCnt).Value) Case CHAR, VARCHAR2 If Trim(objExcel.Cells(j, 3 + lColCnt).Value) Then If Trim(objExcel.Cells(j, 3 + lColCnt).Value) = NULL Then sVALUE_SQL = sVALUE_SQL & null Else sVALUE_SQL = sVALUE_SQL & & objExcel.Cells(j, 3 + lColCnt).Value & End If Else sVALUE_SQL = sVALUE_SQL & End If Case TIMESTAMP sVALUE_SQL = sVALUE_SQL & SYSTIMESTAMP Case DATE If Trim(objExcel.Cells(j, 3 + lColCnt).Value) Then If Trim(objExcel.Cells(j, 3 + lColCnt).Value) = NULL Then sVALUE_SQL = sVALUE_SQL & null Else sVALUE_SQL = sVALUE_SQL & TO_DATE( & Format(CDate(Trim(objExcel.Cells(j, 3 + lColCnt).Value), yyyy/mm/dd) & , YYYY/MM/DD) End If Else sVALUE_SQL = sVALUE_SQL & SYSDATE End If Case Else If Trim(objExcel.Cells(j, 3 + lColCnt).Value) Then If Trim(objExcel.Cells(j, 3 + lColCnt).Value) = NULL Then sVALUE_SQL = sVALUE_SQL & null Else sVALUE_SQL = sVALUE_SQL & objExcel.Cells(j, 3 + lColCnt).Value End If Else sVALUE_SQL = sVALUE_SQL & 0 End If End Select lColCnt = lColCnt + 1 Loop 文字列結合 sMAIN_SQL = sMAIN_SQL = INSERT INTO & Trim(objExcel.Cells(1, 2).Value) & ( & sITEM_SQL & ) _ & vbCrLf & VALUES( & sVALUE_SQL & ) vRet = ExecuteData(sMAIN_SQL) If vRet 0 Then objExcel.Cells(j, 1).Value = sMAIN_SQL GoTo ERR_DB End If 追加件数 lUpCnt = lUpCnt + vRet Else End If 登録確保 If objRegData.Exists(CStr(i) = False Then objRegData.Add CStr(i), Trim(objExcel.Cells(1, 2).Value) End If End If Next jNO_DATA: Next i End With Call DBCommitTrans 登録後検索 If ThisWorkbook.Worksheets(反映).Range(C39).Value Then GoTo DB_CLOSE End If - 出力再読込 - Dim sTableKeys() As Variant sTableKeys = objRegData.