HOMEへ
データベース======================================================
Option Explicit
'**
' データベースオブジェクト
' adoCn コネクション
' adoRs レコードセット
' SQL文
'------------------------------------------------------------------
Public adoCn As Object
Public adoRs As Object
Public strSQL As String
'**
' データベース接続
' @param {Flg : Boolean} trueの場合にオブジェクト作成
'
'------------------------------------------------------------------
Sub DBConnect(Flg As Boolean)
Dim DbPath As String
'DbPath = ThisWorkbook.Path
DbPath = "C:\Users\menta\Desktop\sampleDB"
Set adoCn = CreateObject("ADODB.Connection")
If Flg = True Then Set adoRs = CreateObject("ADODB.Recordset")
' Providerに指定する外部データベースのプロバイダー名
' Access2016/2013/2010/2007 : Microsoft.ACE.OLEDB.12.0
' Access2003/2002 : Microsoft.Jet.OLEDB.4.0
' SQLServer : SQLOLEDB.1
' Oracle : MSDAORA
' DB2 : IBMDADB2
adoCn.Open "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & "\sampleDB.accdb;"
End Sub
'**
' データベース切断
' @param {Flg : Boolean} trueの場合に切断、オブジェクト破棄
'
'------------------------------------------------------------------
Sub DBCuttingOff(Flg As Boolean)
If Flg = True Then adoRs.Close
adoCn.Close
Set adoRs = Nothing
Set adoCn = Nothing
End Sub
'**
' データベースへのインサート
'
'------------------------------------------------------------------
Sub DBinsert()
If MsgBox("データの読み込みを行います。本当にいいですか？", vbOKCancel) = 2 Then
Exit Sub
End If
Dim ws As Worksheet: Set ws = Worksheets("table")
With ws
Dim strSQL As String
Dim start_i As Long, end_i As Long, n As Long
start_i = 2
end_i = .Cells(.Rows.Count, 1).End(xlUp).row
Call DBConnect(False)
On Error GoTo Err_Handler
adoCn.BeginTrans
strSQL = "DELETE FROM [販売管理];"
adoCn.Execute strSQL
For n = start_i To end_i
strSQL = ""
strSQL = strSQL & "INSERT INTO [販売管理](" & vbCrLf
strSQL = strSQL & "[No], " & vbCrLf
strSQL = strSQL & "EccubeCD, " & vbCrLf
strSQL = strSQL & "ItemCD, " & vbCrLf
strSQL = strSQL & "ParentCD, " & vbCrLf
strSQL = strSQL & "ItemName, " & vbCrLf
strSQL = strSQL & "KikakuCD, " & vbCrLf
strSQL = strSQL & "KikakuName, " & vbCrLf
strSQL = strSQL & "KosyouCD, " & vbCrLf
strSQL = strSQL & "KosyouName, " & vbCrLf
strSQL = strSQL & "ZentyouCD, " & vbCrLf
strSQL = strSQL & "Zentyou, " & vbCrLf
strSQL = strSQL & "CategoryCD) " & vbCrLf
strSQL = strSQL & "VALUES(" & vbCrLf
strSQL = strSQL & .Cells(n, 1).Value & ", " & vbCrLf
strSQL = strSQL & "'" & .Cells(n, 2).Value & "', " & vbCrLf
strSQL = strSQL & "'" & .Cells(n, 3).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 4).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 5).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 6).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 7).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 8).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 9).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 10).Value & "', " & vbCrLf
strSQL = strSQL & "'" & Cells(n, 11).Value & "', " & vbCrLf
strSQL = strSQL & "'" & .Cells(n, 12).Value & "')"
adoCn.Execute strSQL
Next n
adoCn.CommitTrans
Call DBCuttingOff(False)
MsgBox "正常に完了しました"
Exit Sub
Err_Handler:
adoCn.RollbackTrans
Call DBCuttingOff(False)
MsgBox Error$
Debug.Print Error$
Debug.Print strSQL
End With
End Sub
'**
' データベースへのセレクト
'
'------------------------------------------------------------------
Sub DBselect()
Dim i As Long, end_i As Long
Call DBConnect(True)
On Error GoTo Err_Handler
strSQL = ""
strSQL = "SELECT * " & vbCrLf
strSQL = strSQL & "FROM [販売管理] " & vbCrLf
strSQL = strSQL & "WHERE [No] >= 163;"
adoRs.Open strSQL, adoCn
If adoRs.BOF = True And adoRs.EOF = True Then
Call DBCuttingOff(True)
MsgBox "対象データがありません"
Exit Sub
End If
Dim ws As Worksheet: Set ws = Worksheets("write")
With ws
i = 2
end_i = .Cells(.Rows.Count, 1).End(xlUp).row
.Range(.Cells(2, 1), .Cells(end_i, 12)).ClearContents
Do Until adoRs.EOF
.Cells(i, 1) = adoRs![No]
.Cells(i, 2) = adoRs!EccubeCD
.Cells(i, 3) = adoRs!ItemCD
.Cells(i, 4) = adoRs!ParentCD
.Cells(i, 5) = adoRs!ItemName
.Cells(i, 6) = adoRs!KikakuCD
.Cells(i, 7) = adoRs!KikakuName
.Cells(i, 8) = adoRs!KosyouCD
.Cells(i, 9) = adoRs!KosyouName
.Cells(i, 10) = adoRs!ZentyouCD
.Cells(i, 11) = adoRs!Zentyou
.Cells(i, 12) = adoRs!CategoryCD
i = i + 1
adoRs.MoveNext
Loop
Call DBCuttingOff(True)
MsgBox "抽出が完了しました"
Exit Sub
End With
Err_Handler:
Call DBCuttingOff(False)
MsgBox Error$
Debug.Print Error$
Debug.Print strSQL
End Sub
'**
' データベースへのアップデート
'
'------------------------------------------------------------------
Sub DBupdate()
Call DBConnect(False)
On Error GoTo Err_Handler
adoCn.BeginTrans
strSQL = ""
strSQL = "UPDATE [販売管理] " & vbCrLf
strSQL = strSQL & "SET " & vbCrLf
strSQL = strSQL & "EccubeCD = '1100', " & vbCrLf
strSQL = strSQL & "ItemCD = 'MENTA-3000', " & vbCrLf
strSQL = strSQL & "ParentCD = '1200', " & vbCrLf
strSQL = strSQL & "ItemName = '目黒邦江', " & vbCrLf
strSQL = strSQL & "KikakuCD = '1300', " & vbCrLf
strSQL = strSQL & "KikakuName = '目黒くにえ', " & vbCrLf
strSQL = strSQL & "KosyouCD = '1400', " & vbCrLf
strSQL = strSQL & "KosyouName = '目黒:DK', " & vbCrLf
strSQL = strSQL & "ZentyouCD = '1500', " & vbCrLf
strSQL = strSQL & "Zentyou = '全長1000', " & vbCrLf
strSQL = strSQL & "CategoryCD = '100:200:300' " & vbCrLf
strSQL = strSQL & "WHERE [No] = 8460;"
adoCn.Execute strSQL
adoCn.CommitTrans
Call DBCuttingOff(False)
MsgBox "正常に更新しました"
Exit Sub
Err_Handler:
adoCn.RollbackTrans
Call DBCuttingOff(False)
MsgBox Error$
Debug.Print Error$
Debug.Print strSQL
End Sub
'**
' データベース Excel用 接続テスト
' コード直書き
'------------------------------------------------------------------
Sub DBConnectTest1()
' オブジェクト作成
' 参照設定チェックが無い場合、CreateObjectにて対応
'--------------------------------------
Dim Con As Object
Dim Rs As Object
Set Con = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
' ドライバー & ファイルパス
'--------------------------------------
Dim DbPath As String
Dim strCon As String
DbPath = "C:\Users\menta\Desktop\sample_test\new価格チェッカー.xlsm"
strCon = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
Con.Open strCon
' SQL組み立て
' 汎用的なフィールド名には [No] 要ブラケット
' FROM句：「Sheet15$A2:L8299」等 $に注意
'--------------------------------------
Dim strSQL As String
strSQL = ""
strSQL = strSQL & "SELECT [No], ItemCD " & vbCrLf
strSQL = strSQL & "FROM [write$] " & vbCrLf
strSQL = strSQL & "WHERE ItemCD = 'BCS00-16-0280-SET-SC-16a'"
strSQL = strSQL & "ORDER BY [No]"
Rs.Open strSQL, Con, adOpenKeyset, adLockReadOnly
' 書き込みここから
'--------------------------------------
Dim i As Long: i = 1
Do Until Rs.EOF
Sheets("Sheet3").Cells(i, 1).Value = Rs![No]
Sheets("Sheet3").Cells(i, 2).Value = Rs!ItemCD
Rs.MoveNext
i = i + 1
Loop
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
End Sub
'**
' データベース Access用 接続テスト
' コード直書き
'------------------------------------------------------------------
Sub DBConnectTest2()
' オブジェクト作成
'--------------------------------------
Dim Con As ADODB.Connection
Dim Rs As ADODB.Recordset
Set Con = New ADODB.Connection
Set Rs = New ADODB.Recordset
' ドライバー & ファイルパス
'--------------------------------------
Dim DbPath As String: DbPath = "C:\Users\menta\Desktop\sampleDB"
Con.Open "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & "\sampleDB.accdb;"
' error
'--------------------------------------
On Error GoTo Err_Handler
' SQL組み立て
'--------------------------------------
strSQL = ""
strSQL = "SELECT * " & vbCrLf
strSQL = strSQL & "FROM [販売管理] " & vbCrLf
strSQL = strSQL & "WHERE [No] >= 1 AND [No] <= 800;"
Rs.Open strSQL, Con, adOpenForwardOnly, adLockReadOnly
' BOF EOFチェック
'--------------------------------------
If Rs.BOF = True And Rs.EOF = True Then
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
MsgBox "対象データがありません"
Exit Sub
End If
' 書き込みシート準備(既存データ削除など)
'--------------------------------------
Dim ws As Worksheet: Set ws = Worksheets("write")
With ws
Dim last_row As Long, i As Long: i = 2
last_row = .Cells(.Rows.Count, 1).End(xlUp).row
.Range(.Cells(2, 1), .Cells(last_row, 12)).Delete
' 書き込みここから
'--------------------------------------
Do Until Rs.EOF
.Cells(i, 1) = Rs![No]
.Cells(i, 2) = Rs!EccubeCD
.Cells(i, 3) = Rs!ItemCD
.Cells(i, 4) = Rs!ParentCD
.Cells(i, 5) = Rs!ItemName
.Cells(i, 6) = Rs!KikakuCD
.Cells(i, 7) = Rs!KikakuName
.Cells(i, 8) = Rs!KosyouCD
.Cells(i, 9) = Rs!KosyouName
.Cells(i, 10) = Rs!ZentyouCD
.Cells(i, 11) = Rs!Zentyou
.Cells(i, 12) = Rs!CategoryCD
i = i + 1
Rs.MoveNext
Loop
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
MsgBox "抽出が完了しました"
Exit Sub
End With
' error
'--------------------------------------
Err_Handler:
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
MsgBox Error$
Debug.Print Error$
Debug.Print strSQL
End Sub
'**
' データベース Access用 接続テスト ロールバック
' コード直書き
'------------------------------------------------------------------
Sub DBConnectTest3()
' オブジェクト作成
'--------------------------------------
Dim Con As ADODB.Connection
Dim Rs As ADODB.Recordset
Set Con = New ADODB.Connection
Set Rs = New ADODB.Recordset
' ドライバー & ファイルパス
'--------------------------------------
Dim DbPath As String: DbPath = "C:\Users\menta\Desktop\sampleDB"
Con.Open "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & DbPath & "\sampleDB.accdb;"
' エラー処理
'--------------------------------------
On Error GoTo Err_Handler
' トランザクションスタート
'--------------------------------------
Con.BeginTrans
' SQL組み立て
'--------------------------------------
strSQL = ""
strSQL = "UPDATE [販売管理] " & vbCrLf
strSQL = strSQL & "SET " & vbCrLf
strSQL = strSQL & "EccubeCD = '1100', " & vbCrLf
strSQL = strSQL & "ItemCD = 'MENTA-3000', " & vbCrLf
strSQL = strSQL & "ParentCD = '1200', " & vbCrLf
strSQL = strSQL & "ItemName = '目黒邦江', " & vbCrLf
strSQL = strSQL & "KikakuCD = '1300', " & vbCrLf
strSQL = strSQL & "KikakuName = '目黒くにえ', " & vbCrLf
strSQL = strSQL & "KosyouCD = '1400', " & vbCrLf
strSQL = strSQL & "KosyouName = '目黒:DK', " & vbCrLf
strSQL = strSQL & "ZentyouCD = '1500', " & vbCrLf
strSQL = strSQL & "Zentyou = '全長1000', " & vbCrLf
strSQL = strSQL & "CategoryCD = '100:200:300' " & vbCrLf
strSQL = strSQL & "WHERE [No] = 8460;"
' ※UPDATEにおける、Openでの引数は「adOpenDynamic」、「adLockOptimistic」を使用すること
Rs.Open strSQL, Con, adOpenDynamic, adLockOptimistic
' トランザクションコミット
'--------------------------------------
Con.CommitTrans
MsgBox "正常に更新しました"
Exit Sub
' BOF EOFチェック
'--------------------------------------
If Rs.BOF = True And Rs.EOF = True Then
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
MsgBox "対象データがありません"
Exit Sub
End If
' 書き込みシート準備(既存データ削除など)
'--------------------------------------
Dim ws As Worksheet: Set ws = Worksheets("write")
With ws
Dim last_row As Long, i As Long: i = 2
last_row = .Cells(.Rows.Count, 1).End(xlUp).row
.Range(.Cells(2, 1), .Cells(last_row, 12)).Delete
' 書き込みここから
'--------------------------------------
Do Until Rs.EOF
.Cells(i, 1) = Rs![No]
.Cells(i, 2) = Rs!EccubeCD
.Cells(i, 3) = Rs!ItemCD
.Cells(i, 4) = Rs!ParentCD
.Cells(i, 5) = Rs!ItemName
.Cells(i, 6) = Rs!KikakuCD
.Cells(i, 7) = Rs!KikakuName
.Cells(i, 8) = Rs!KosyouCD
.Cells(i, 9) = Rs!KosyouName
.Cells(i, 10) = Rs!ZentyouCD
.Cells(i, 11) = Rs!Zentyou
.Cells(i, 12) = Rs!CategoryCD
i = i + 1
Rs.MoveNext
Loop
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
MsgBox "抽出が完了しました"
Exit Sub
End With
' error
'--------------------------------------
Err_Handler:
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
MsgBox Error$
Debug.Print Error$
Debug.Print strSQL
End Sub
Option Explicit
Private adoCn As Object
Private adoRs As Object
Private strSQL As String
Public Sub dbConnect(flg As Boolean)
Dim dbPath As String
dbPath = ThisWorkbook.Path
Set adoCn = New ADODB.Connection
With adoCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source = " & ThisWorkbook.FullName & "; Extended Properties =Excel 12.0;"
End With
If flg = True Then
Set adoRs = New ADODB.Recordset
End If
End Sub
Public Sub dbConnectCut(flg As Boolean)
If flg = True Then adoRs.Close
adoCn.Close
Set adoRs = Nothing
Set adoCn = Nothing
End Sub