Excel VBAデータベースシステム入門
Excelにデータベースを組み合わせると、高機能な、標準化された、使いやすいシステムを構築することができます。しかし、データベースを利用するシステムは製作困難で、専門家でないとなかなか製作できません。今回公開しました「EXCELVBA自動作成データベース用」を活用すると、データ入力、更新のプログラムが自動作成でき、容易にシステム構築できます。
事例として、通信販売等の出荷、在庫管理のシステムを製作致しました。処理内容、主なプログラムについて説明させていただきます。
システムのダウンロード (ソース公開)
テーブルの作成
本システムでは4つのテーブルを使用します。
1つのテーブル 受注残について、テーブル作成方法を説明致します。
データベースとしてAccsessデータベースエンジン を使用しました。
プログラムの作成、運用には、Accsessは不要です。
データベース検索・更新プログラムの作成
受注残のデータをExcelで作成します。
データを1行程度入力しておきます。(テーブル作成時、数字、文字、日付のデータ型を自動設定します。)
ホルダ order に受注残.xlsとして保存しました。
ダウンロードしたExcelVBA自動作成データベース用のホルダVBAJDB内に空のデータベースtemp.accdbが入っています。
これをホルダ orderにコピーし、名前を受注出荷DB.accdbに変更します。
受注残を開きます。
ダウンロードした VBAJDB内 の自動M.XLSを開くと、アドイン内に VBA自動作成DBが作成されます。
VBA自動作成DBを押します。
DBMを選択し、作成を押します。
初めて使用するときサンプル利用パスワードの入力が必要になります。
ホームページ http://kanacom2.la.coocan.jp 内のサンプル利用パスワード4文字を入力します。
表示されるフォームに設定します。
①作成したデータベースを選択します。
②テーブル名を選択します。
③項目名の範囲を選択します。
④キーの項目 受注番号 を選択します。この値でデータを更新しますので、このデータは重複してはいけません。
⑤更新チェック用の列 最後の項目より 右のセルを選択します。3列使用し、読み込み時のデータ、現在のデータ、更新判断に利用します。
⑥更新日時を登録する列を選択 追加、更新時にその日時を自動記入します。
OK を押すと7本のプログラムが自動作成されます。
受注残全検索
受注残テーブルから検索し、受注残シートに貼り付けます。検索条件を受注残シートのテキストボックスSQLに入力しておきます。
受注残変更行更新
受注残シートのデータ修正、追加行があればテーブルを更新します。キーは受注番号です。
受注残テーブルから検索したとき、その内容をO列移行に記入し、改定された項目のみ更新するようになっています。
(複数人が同一行の更新可能。)
受注残管理番号最大値検索(MAXNO)
データ追加するとき、シリアル番号を作成している場合の現在の最大値を検索します。
受注残テーブル削除
表示されている行を削除します。パスワード1111
受注残テーブル全削除
受注残全データを削除します。
受注残テーブル挿入
無条件でデータ追加します。
受注残テーブル作成
受注残テーブルを作成します。
|
Sub 受注残全検索() Application.Calculation = xlManual '' Sheets("受注残").DrawingObjects("sql").Characters.Text = "受注番号 LIKE '%'" 'フィルタ解除 Set BK = ActiveWorkbook Set INS = BK.Sheets("受注残") '入力出力シート If INS.AutoFilterMode Then INS.Range("$A2").AutoFilter End If 受注残テーブル検索高速貼付 受注残旧データ式コピー Application.Calculation = xlAutomatic End Sub
Sub 受注残変更行更新() 'フィルタ解除 Set BK = ActiveWorkbook Set INS = BK.Sheets("受注残") '入力出力シート If INS.AutoFilterMode Then INS.Range("$A2").AutoFilter End If 'Application.ScreenUpdating = True 受注残更新判断式コピー 受注残テーブル更新挿入 受注残旧データ式コピー End Sub
Sub 受注残旧データ式コピー() Dim BK, INS, ENDROW Application.ScreenUpdating = False Set BK = ActiveWorkbook Set INS = BK.Sheets("受注残") '入力出力シート ENDROW = INS.Range("$A65536").End(xlUp).Row '最終行判断 If ENDROW < 3 Then Exit Sub End If ra = Array("$P") ''''標準書式への変更 For K = LBound(ra) To UBound(ra) INS.Range(ra(K) & "3:" & ra(K) & ENDROW).NumberFormatLocal = "G/標準" Next K INS.Range("$P3").Formula = "=$A3&""|""&$B3&""|""&$C3&""|""&$D3&""|""&$E3&""|""&$F3&""|""&$G3&""|""&$H3&""|""&$I3&""|""&$J3&""|""&""|""" For K = LBound(ra) To UBound(ra) INS.Range(ra(K) & "3").Copy INS.Range(ra(K) & "3:" & ra(K) & ENDROW).PasteSpecial Paste:=xlFormulas Next K '値としてコピー INS.Calculate ''''計算実行 For K = LBound(ra) To UBound(ra) INS.Range(ra(K) & "3:" & ra(K) & ENDROW).Copy INS.Range(ra(K) & "3:" & ra(K) & ENDROW).PasteSpecial Paste:=xlValues Next K End Sub
Sub 受注残更新判断式コピー() Dim BK, INS, ENDROW Application.ScreenUpdating = False Set BK = ActiveWorkbook Set INS = BK.Sheets("受注残") '入力出力シート ENDROW = INS.Range("$A65536").End(xlUp).Row '最終行判断 If ENDROW < 3 Then Exit Sub End If ra = Array("$O", "$Q") ''''標準書式への変更 For K = LBound(ra) To UBound(ra) INS.Range(ra(K) & "3:" & ra(K) & ENDROW).NumberFormatLocal = "G/標準" Next K INS.Range("$O3").Formula = "=IF($P3<>$Q3,1,"""")" INS.Range("$Q3").Formula = "=$A3&""|""&$B3&""|""&$C3&""|""&$D3&""|""&$E3&""|""&$F3&""|""&$G3&""|""&$H3&""|""&$I3&""|""&$J3&""|""&""|""" For K = LBound(ra) To UBound(ra) INS.Range(ra(K) & "3").Copy INS.Range(ra(K) & "3:" & ra(K) & ENDROW).PasteSpecial Paste:=xlFormulas Next K '値としてコピー INS.Calculate ''''計算実行 For K = LBound(ra) To UBound(ra) INS.Range(ra(K) & "3:" & ra(K) & ENDROW).Copy INS.Range(ra(K) & "3:" & ra(K) & ENDROW).PasteSpecial Paste:=xlValues Next K End Sub
Sub 受注残テーブル検索高速貼付() Set BK = ActiveWorkbook ''THISWORKBOOK Set OUS = BK.Sheets("受注残") OU = 3 '出力開始行 OUS.Range("A" & OU & ":IV65536").ClearContents ''出力シート全消去 受注残テーブル検索高速貼付2 End Sub
Sub 受注残テーブル検索高速貼付2() '追加貼り付け Dim rst As Object Dim NewDB As Object Dim BK, OUS, STRSQL, CNT, OU Set rst = CreateObject("ADODB.Recordset") Set NewDB = CreateObject("ADODB.Connection") 'Application.DisplayAlerts = False ''メッセージ非表示 Application.ScreenUpdating = False ''画面表示無 Set BK = ActiveWorkbook ''THISWORKBOOK Set OUS = BK.Sheets("受注残") Call dbopen(NewDB) ''データベースとの接続 STRSQL = "SELECT 受注番号,受注日,顧客名,顧客住所,品目コード,数量,品名,単価,金額,出荷日,更新日時 FROM 受注残" STRSQL = STRSQL & " WHERE " & OUS.DrawingObjects("sql").Characters.Text STRSQL = STRSQL & ";" rst.Open STRSQL, NewDB, 3, 1 ''''adOpenStatic, adLockReadOnly CNT = rst.RecordCount ''''件数 OU = OUS.Range("$A65536").End(xlUp).Row + 1 ''5 ''追加出力 Dim MM(1 To 11) If Not (rst.EOF) Then ''データあり？ Do Until rst.EOF For J = 1 To 11 MM(J) = rst.Fields(J - 1).Value Next J OUS.Range("$A" & OU).Resize(, 11).Value = MM OU = OU + 1 rst.MoveNext ''次のデータ Application.StatusBar = OU - 1 & "<-" & CNT + 2 Loop End If rst.Close Set rst = Nothing End Sub Sub 受注残管理番号最大値検索(MAXNO) Dim rst As Object Dim NewDB As Object Dim STRSQL, CNT Set rst = CreateObject("ADODB.Recordset") Set NewDB = CreateObject("ADODB.Connection") Call dbopen(NewDB) ''データベースとの接続 STRSQL = "SELECT max(受注番号) FROM 受注残" STRSQL = STRSQL & ";" rst.Open STRSQL, NewDB, 3, 1 ''''adOpenStatic, adLockReadOnly CNT = rst.RecordCount ''''件数 MAXNO = "" If CNT > 0 Then MAXNO = rst.Fields(0).Value End If rst.Close Set rst = Nothing End Sub
Sub 受注残テーブル更新挿入() Dim rst As Object Dim NewDB As Object Dim BK, OUS, STRSQL, CNT, OU Set rst = CreateObject("ADODB.Recordset") Set NewDB = CreateObject("ADODB.Connection") 'Application.DisplayAlerts = False ''メッセージ非表示 Application.ScreenUpdating = False ''画面表示無 Set BK = ActiveWorkbook ''THISWORKBOOK Set INS = BK.Sheets("受注残") '入力出力シート Call dbopen(NewDB) ''データベースとの接続 EN = INS.Range("$A65536").End(xlUp).Row '最終行判断 NNOW = Now '更新日時 If EN >= 3 Then CT1 = 0 CT2 = 0 For I = 3 To EN key1 = INS.Range("$A" & I).Value 更新 = INS.Range("$O" & I).Value If 更新 = 1 Then '更新されている If key1 <> "" Then 'キーがある INS.Range("$K" & I).Value = NNOW ''更新日登録 STRSQL = "SELECT 受注番号,受注日,顧客名,顧客住所,品目コード,数量,品名,単価,金額,出荷日,更新日時 FROM 受注残" If key1 <> "" Then STRSQL = STRSQL & " WHERE 受注番号='" & key1 & "'" STRSQL = STRSQL & ";" '''' rst.Open STRSQL, NewDB, 1, 3 ''1,3adOpenKeyset, adLockOptimistic ''3,1adOpenStatic, adLockReadOnly CNT = rst.RecordCount ''''件数 If Not (rst.EOF) Then ''データあり？ '' Do Until rst.EOF 旧DAT = INS.Range("$P" & I).Value If 旧DAT = "" Then 旧DAT = String(11, "|") '新規データ 旧 = Split(旧DAT, "|") 新 = Split(INS.Range("$Q" & I).Value, "|") If 旧(0) <> 新(0) Then rst.Fields("受注番号").Value = NULLCH(INS.Range("$A" & I).Value) ''0 If 旧(1) <> 新(1) Then rst.Fields("受注日").Value = NULLCH(INS.Range("$B" & I).Value) ''1 If 旧(2) <> 新(2) Then rst.Fields("顧客名").Value = NULLCH(INS.Range("$C" & I).Value) ''2 If 旧(3) <> 新(3) Then rst.Fields("顧客住所").Value = NULLCH(INS.Range("$D" & I).Value) ''3 If 旧(4) <> 新(4) Then rst.Fields("品目コード").Value = NULLCH(INS.Range("$E" & I).Value) ''4 If 旧(5) <> 新(5) Then rst.Fields("数量").Value = NULLCH(INS.Range("$F" & I).Value) ''5 If 旧(6) <> 新(6) Then rst.Fields("品名").Value = NULLCH(INS.Range("$G" & I).Value) ''6 If 旧(7) <> 新(7) Then rst.Fields("単価").Value = NULLCH(INS.Range("$H" & I).Value) ''7 If 旧(8) <> 新(8) Then rst.Fields("金額").Value = NULLCH(INS.Range("$I" & I).Value) ''8 If 旧(9) <> 新(9) Then rst.Fields("出荷日").Value = NULLCH(INS.Range("$J" & I).Value) ''9 rst.Fields("更新日時").Value = NULLCH(INS.Range("$K" & I).Value) ''10 rst.Update '''' rst.Delete ''''''削除 CT1 = CT1 + 1 ''更新 '' rst.MoveNext ''次のデータ '' Loop rst.Close Else rst.AddNew rst.Fields("受注番号").Value = NULLCH(INS.Range("$A" & I).Value) ''0 rst.Fields("受注日").Value = NULLCH(INS.Range("$B" & I).Value) ''1 rst.Fields("顧客名").Value = NULLCH(INS.Range("$C" & I).Value) ''2 rst.Fields("顧客住所").Value = NULLCH(INS.Range("$D" & I).Value) ''3 rst.Fields("品目コード").Value = NULLCH(INS.Range("$E" & I).Value) ''4 rst.Fields("数量").Value = NULLCH(INS.Range("$F" & I).Value) ''5 rst.Fields("品名").Value = NULLCH(INS.Range("$G" & I).Value) ''6 rst.Fields("単価").Value = NULLCH(INS.Range("$H" & I).Value) ''7 rst.Fields("金額").Value = NULLCH(INS.Range("$I" & I).Value) ''8 rst.Fields("出荷日").Value = NULLCH(INS.Range("$J" & I).Value) ''9 rst.Fields("更新日時").Value = NULLCH(INS.Range("$K" & I).Value) ''10 rst.Update CT2 = CT2 + 1 ''追加 rst.Close End If End If End If Application.StatusBar = I & "<-" & EN Next I End If If CT1 + CT2 = 0 Then MsgBox ("更新データありません") Else MsgBox ("更新" & CT1 & "件 追加" & CT2 & "件 ありました") End If Set rst = Nothing End Sub
Sub 受注残テーブル削除() Dim rst As Object Dim NewDB As Object Dim BK, OUS, STRSQL, CNT, OU YN = MsgBox("表示されているデータを削除します", vbYesNo) If YN <> vbYes Then End End If PAS = InputBox("パスワード") If PAS <> "1111" Then End End If Set rst = CreateObject("ADODB.Recordset") Set NewDB = CreateObject("ADODB.Connection") 'Application.DisplayAlerts = False ''メッセージ非表示 Application.ScreenUpdating = False ''画面表示無 Set BK = ActiveWorkbook ''THISWORKBOOK Set INS = BK.Sheets("受注残") '入力出力シート Call dbopen(NewDB) ''データベースとの接続 EN = INS.Range("$A65536").End(xlUp).Row '最終行判断 If EN >= 3 Then CT1 = 0 For I = 3 To EN key1 = INS.Range("$A" & I).Value STRSQL = "SELECT 受注番号,受注日,顧客名,顧客住所,品目コード,数量,品名,単価,金額,出荷日,更新日時 FROM 受注残" STRSQL = STRSQL & " WHERE 受注番号='" & key1 & "'" STRSQL = STRSQL & ";" '''' rst.Open STRSQL, NewDB, 1, 3 ''1,3adOpenKeyset, adLockOptimistic ''3,1adOpenStatic, adLockReadOnly CNT = rst.RecordCount ''''件数 If Not (rst.EOF) Then ''データあり？ Do Until rst.EOF rst.Delete ''''''削除 CT1 = CT1 + 1 ''更新 rst.MoveNext ''次のデータ Loop End If rst.Close Application.StatusBar = I & "<-" & EN Next I End If If CT1 = 0 Then MsgBox ("削除データありません") Else MsgBox ("削除" & CT1 & "件 ありました") End If Set rst = Nothing End Sub
Function NULLCH(A) If A = "" Then NULLCH = Null Else NULLCH = A End Function Function NULLSP(A) If A = "" Then NULLSP = " " Else NULLSP = A End Function
Sub 受注残テーブル挿入() 'テーブルに追加 Dim rst As Object Dim NewDB As Object Dim BK, OUS, STRSQL, CNT, OU Set rst = CreateObject("ADODB.Recordset") Set NewDB = CreateObject("ADODB.Connection") Application.DisplayAlerts = False ''メッセージ非表示 Application.ScreenUpdating = False ''画面表示無 Set BK = ActiveWorkbook ''THISWORKBOOK Set INS = BK.Sheets("受注残") Call dbopen(NewDB) ''データベースとの接続 EN = INS.Range("$A65536").End(xlUp).Row '最終行判断 If EN >= 3 Then STRSQL = "SELECT 受注番号,受注日,顧客名,顧客住所,品目コード,数量,品名,単価,金額,出荷日,更新日時 FROM 受注残" STRSQL = STRSQL & ";" '''' rst.Open STRSQL, NewDB, 1, 3 ''1,3adOpenKeyset, adLockOptimistic ''3,1adOpenStatic, adLockReadOnly CNT = rst.RecordCount ''''件数 For I = 3 To EN rst.AddNew rst.Fields("受注番号").Value = NULLCH(INS.Range("$A" & I).Value) ''0 rst.Fields("受注日").Value = NULLCH(INS.Range("$B" & I).Value) ''1 rst.Fields("顧客名").Value = NULLCH(INS.Range("$C" & I).Value) ''2 rst.Fields("顧客住所").Value = NULLCH(INS.Range("$D" & I).Value) ''3 rst.Fields("品目コード").Value = NULLCH(INS.Range("$E" & I).Value) ''4 rst.Fields("数量").Value = NULLCH(INS.Range("$F" & I).Value) ''5 rst.Fields("品名").Value = NULLCH(INS.Range("$G" & I).Value) ''6 rst.Fields("単価").Value = NULLCH(INS.Range("$H" & I).Value) ''7 rst.Fields("金額").Value = NULLCH(INS.Range("$I" & I).Value) ''8 rst.Fields("出荷日").Value = NULLCH(INS.Range("$J" & I).Value) ''9 rst.Fields("更新日時").Value = NULLCH(INS.Range("$K" & I).Value) ''10 rst.Update Application.StatusBar = I & "<-" & EN Next I rst.Close End If Set rst = Nothing End Sub ' Sub 受注残テーブル作成() Set NewDB = CreateObject("ADODB.Connection") Set cmd = CreateObject("ADODB.Command") Dim mySQL As String YN = MsgBox("受注残テーブル作成します 作成済みのとき全データを削除します", vbYesNo) If YN <> vbYes Then End End If PAS = InputBox("パスワード") If PAS <> "1111" Then End End If Call dbopen(NewDB) cmd.ActiveConnection = NewDB '既にテーブルが存在していたら削除する mySQL = "DROP TABLE 受注残;" cmd.CommandText = mySQL On Error Resume Next cmd.Execute On Error GoTo 0 ' 他のデータ型 INTEGER 整数 MEMO 長い文字 mySQL = "CREATE TABLE 受注残 (" & _ "受注番号 TEXT(255)," & _ "受注日 DATETIME," & _ "顧客名 TEXT(255)," & _ "顧客住所 TEXT(255)," & _ "品目コード TEXT(255)," & _ "数量 FLOAT," & _ "品名 TEXT(255)," & _ "単価 FLOAT," & _ "金額 FLOAT," & _ "出荷日 TEXT(255)," & _ "更新日時 DATETIME);" cmd.CommandText = mySQL cmd.Execute 'キー設定例 重複ならUNIQUEを取る 'cmd.CommandText = "CREATE UNIQUE INDEX index1 ON 受注残 (商品ｺｰﾄﾞ);": cmd.Execute Set NewDB = Nothing MsgBox ("テーブル 受注残を作成しました") End Sub
Sub 受注残テーブル全削除() YN = MsgBox("受注残全データを削除します", vbYesNo) If YN <> vbYes Then End End If PAS = InputBox("パスワード") If PAS <> "1111" Then End End If Set NewDB = CreateObject("ADODB.Connection") Set cmd = CreateObject("ADODB.Command") Dim mySQL As String Dim strName As String Dim strMsg As String Call dbopen(NewDB) cmd.ActiveConnection = NewDB mySQL = "DELETE * FROM 受注残 ;" cmd.CommandText = mySQL cmd.Execute Set NewDB = Nothing End Sub ' Sub dbopen(NewDB) 'データベースとの接続 ''NewDB.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=E:\製作マクロ\order\受注出荷DB.accdb;" NewDB.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & ThisWorkbook.Path & "\受注出荷DB.accdb;" End Sub
|
受注残テーブル作成 を実行すると受注出荷DB.accdb内にテーブルが作成され、データの登録、更新、検索ができるようになります。
使用例
受注残シートにテストデータを貼り付けます。
次のプログラムをModule2に入力し実行します。Module1には自動作成したプログラムが入力されています。
追加 20件 と表示され、データベースに登録されました。
データを検索してみます。
データを消去します。
受注残シートにテキストボックスを作成します。名前をSQLとします。
プログラムIWA2を入力し、実行します。すべての受注番号を検索する意味です。
データが検索されました。
データを修正してみます。4行数量、 5行出荷日を入力。
プログラムIWA3を入力し、実行します。
更新2件されました。
このように自動作成されたプログラムを使うと、データベースを自由に扱うことができます。
これを利用してシステムを構築します。
残りの3つのテーブルと検索・更新プログラムも同様に作ります。
テーブルメンテ.xlsの中にまとめて作成しておくとテーブルの表示、修正に便利です。
在庫
在庫手配残
在庫入出庫
実績データなど更新用のキー(データを確定できる項目)が見つからない場合は ID という項目を先頭列に作ります。
データ登録されるごとに自動的にカウントアップされ更新用のキーになります。
IDは手入力不可です。
参考
作成したシステムのメニュー
