Excel VBA の備忘録　～DBの更新～

久しぶりの投稿となります。マクロの勉強を兼ねて、DBの更新プログラムを書いてみたので、備忘録を残したいと思います。

機能
処理機能
実装
追加が必要な機能

機能

顧客管理を前提として作成し、顧客の住所等情報と、契約日・内容についてのDBとなります。機能は絞って実装しました。以下の事ができます。

新規企業の追加
新しい契約の追加
過去の契約の修正
企業の削除

必要に応じて拡張すれば応用して使用できるかと思います。

処理機能

以下がTOPとなります。

まず、会社名のところに表示したい会社名を入れて「検索」を押すと、その会社の情報が表示されます。もし、その会社がDBにない場合はその旨IDの欄に表示されます。

ところで、会社名が多くなると検索したくなるかと思います。そこで、会社名の下の欄に「会社検索文字を入力→」を設け、

文字の一部を入力するとその文字を含む会社が会社名のセルにリストとして表示される

ようにしました。コメントを入れておきましたので、参考にしてください。

次に新規、更新、削除の部分です。「新規あるいは更新」ボタンを押すと、新たに契約日や契約内容が追加され、過去の契約日や契約内容は一つ古いデータへ移行されます。なお、修正のみ行いたい場合は「更新」のボタンとなります。また、「削除」ボタンはDBからの削除です。

実装

シートは以下６枚です。

契約情報	契約情報を表示するシート（通常このシートのみ使用します）
契約情報_処理	契約情報を表示するシートにマクロでコピーを行うための元データ
更新	このシートのデータを用いてDBを更新
リスト	シート「契約情報」で検索を行う時に使用
DB	DB
DB_ORG	DBのオリジナル。実際に更新、修正等を行うとDBが上書きされるので、オリジナルからコピーして使用

少し工夫した点に絞って以下説明したいと思います。後は中身を見ればわかると思います。

まず、マクロから。一つ目は「検索」ですが、すでに、シート「契約情報_処理」にデータができているので、こちらを「契約情報」にコピーするだけです。

Sub 検索()
    '企業のデータをシート「契約情報_処理」から「契約情報」に張り付ける
    Range("B6").Value = Worksheets("契約情報_処理").Range("C6").Value
    ＜中略＞
    Range("B38").Value = Worksheets("契約情報_処理").Range("C38").Value
End Sub

Sub 検索()

'企業のデータをシート「契約情報_処理」から「契約情報」に張り付ける

Range("B6").Value = Worksheets("契約情報_処理").Range("C6").Value

＜中略＞

Range("B38").Value = Worksheets("契約情報_処理").Range("C38").Value

End Sub

つづいて、「更新_追加あり」です。シート「更新」のセルA9に更新すべき行を算出しています。ない場合は最終行の１行下を指すようにしています。また、シート「更新」のA2:P2には「契約情報」から更新すべきデータが抽出されているのでその行をコピーする形となります。

Sub 更新_追加あり()
    '契約追加（新規を含む）場合の処理
    Dim i As Long
    i = Worksheets("更新").Range("A9").Value
    Worksheets("DB").Range(Cells(i, 1), Cells(i, 16)).Value = _
    Worksheets("更新").Range("A2:P2").Value
    MsgBox "DBに新規／契約追加を行いました"
End Sub

Sub 更新_追加あり()

'契約追加（新規を含む）場合の処理

Dim i As Long

i = Worksheets("更新").Range("A9").Value

Worksheets("DB").Range(Cells(i, 1), Cells(i, 16)).Value = _

Worksheets("更新").Range("A2:P2").Value

MsgBox "DBに新規／契約追加を行いました"

End Sub

「更新_追加なし」もほぼ同様ですが、シート「更新」のA3:P3に修正すべきデータが記載されているので、こちらをコピーすることになります。ここまででお分かりになるかとも思いますが、

できるだけ関数で記述し、VBAは最低限

を意識しています。

Sub 更新_追加なし()
    '修正の場合の処理
    Dim i As Long
    i = Worksheets("更新").Range("A9").Value
    Worksheets("DB").Range(Cells(i, 1), Cells(i, 16)).Value = _
    Worksheets("更新").Range("A3:P3").Value
    MsgBox "DBを修正しました"
End Sub

Sub 更新_追加なし()

'修正の場合の処理

Dim i As Long

i = Worksheets("更新").Range("A9").Value

Worksheets("DB").Range(Cells(i, 1), Cells(i, 16)).Value = _

Worksheets("更新").Range("A3:P3").Value

MsgBox "DBを修正しました"

End Sub

最後に削除です。DBの最大は1000としており、削除した行を詰める作業となります。ここでDeleteを使用していないのは、シート「契約情報_処理」のVLOOKUPで「DB」を参照しており、式が自動変換されてしまうためです。具体的には、現在1000データを参照するよう記載してますが、999データのみ参照するようになってしまいます。

Sub 削除()
    Dim i As Long
    i = Worksheets("更新").Range("A9").Value
    If i < 1001 Then
        Worksheets("DB").Range(Cells(i, 1), Cells(1000, 16)).Value = _
        Worksheets("DB").Range(Cells(i + 1, 1), Cells(1001, 16)).Value
    End If
    MsgBox "DBから削除しました"
End Sub

Sub 削除()

Dim i As Long

i = Worksheets("更新").Range("A9").Value

If i < 1001 Then

Worksheets("DB").Range(Cells(i, 1), Cells(1000, 16)).Value = _

Worksheets("DB").Range(Cells(i + 1, 1), Cells(1001, 16)).Value

End If

MsgBox "DBから削除しました"

End Sub

最後に、Functionを作ってみました。最終行を算出してくれるものです。

Function Lastline()
    'DBの最終行を求める処理。シート「更新」のDBの対象行を求める際に使用
    Lastline = Worksheets("DB").Cells(Rows.Count, 1).End(xlUp).Row
End Function

Function Lastline()

'DBの最終行を求める処理。シート「更新」のDBの対象行を求める際に使用

Lastline = Worksheets("DB").Cells(Rows.Count, 1).End(xlUp).Row

End Function

「更新」のセルA9で使用しています。

追加が必要な機能

実際に使用するには以下のような追加機能が必要かと思います。

IDがダブっていることを知らせる
IDは半角、企業名は全角などで統一するようプログラムで自動変換
更新とか修正するときに本当に良いか尋ねるメッセージ表示
1000件を超えて入れようとすると、入らない旨のメッセージが出る。

とりあえず、ベースを記載したところで今回はここまでで。

ソースはこちら→契約企業情報

どうも拡張子がxlmsのファイルはwordpressアップできないので、xlsxに書き換えています、、、。うまくxlsmがアップでき次第解消したいと思います。