HOME

 

Excel VBAデータベースシステム入門

 

 

はじめに

 

Excelにデータベースを組み合わせると、高機能な、標準化された、使いやすいシステムを構築することができます。しかし、データベースを利用するシステムは製作困難で、専門家でないとなかなか製作できません。今回公開しました「EXCELVBA自動作成データベース用」を活用すると、データ入力、更新のプログラムが自動作成でき、容易にシステム構築できます。

事例として、通信販売等の出荷、在庫管理のシステムを製作致しました。処理内容、主なプログラムについて説明させていただきます。

 

システムのダウンロード (ソース公開)

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文字を入力します。

 

表示されるフォームに設定します。

 

@作成したデータベースを選択します。

Aテーブル名を選択します。

B項目名の範囲を選択します。

Cキーの項目 受注番号 を選択します。この値でデータを更新しますので、このデータは重複してはいけません。

D更新チェック用の列 最後の項目より 右のセルを選択します。3列使用し、読み込み時のデータ、現在のデータ、更新判断に利用します。

E更新日時を登録する列を選択 追加、更新時にその日時を自動記入します。

 

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は手入力不可です。

 

参考

作成したシステムのメニュー

 

 

HOME