TeraOmegaNetwork 2.0「Excel VBA DB項目更新チェック」

お勧め１「テンプレート作成支援言語（T言語)」ver 1.1.1         20010/02/26 更新
テンプレート作成支援言語について
ダウンロードする。

お勧め２「ブラウザ自動操作ツール（IEAuto2009)」ver 1.6.1    20010/03/25 更新
ブラウザ自動操作ツール（IEAuto 2009)について
ダウンロードする。

お勧め３「データベース更新前更新後比較ツール(DBCMP) Oracle接続可」ver 1.4.0  20010/03/14 新規公開
ダウンロードする。

管理人の落書き　-　--------------

Excel VBA DB項目更新チェック

会社のセキュリティ上、ソフトがダウンロードできない状況でもテキスト（ここに書いてある
マクロを見ることはできますからねｗ）と言うわけでちょっとマクロをコピペしてみました。
本当は、SQL接続部分とかあるのですが、落書きが大きくなるので省略。

内容は、データベースの更新前、更新後を比較したいときに使うマクロです。（2つの表の差分を求める）
実際に実装してみると、比較シートの方に、削除、登録、更新が人目で分かるように表示されます。
前提条件として、プライマリキーで、更新前、更新後の明細はソート（昇順）しておくこと。
ヘッダー部分には、アンダーバーを引いておく。（ルール無視すると無限ループ発生します！）
使う場合は、このマクロをコピーして適当に編集してください。もしかすると何か関数がもれてる
かもしれないです。その変は臨機応変と言うことで。責任取れません。

更新前のシートと更新後のシートと、さらに比較するようのシートを３つ用意する。

そして、以下のマクロを定義する。

★比較シートに記述
Option Explicit

Dim Before As Worksheet  '更新後シート
Dim After As Worksheet   '更新前シート
Dim Cmp As Worksheet     '比較用シート

Dim PkeyCol As Integer   'プライマリキーの最終列位置（例：主キーが３つあった場合は３になる）

Const START_COL As Integer = 2      '比較開始行
Const ATTRIBUTE_COL As Integer = 1  '属性行

'エントリーポイント
'更新前と更新後で比較を行う。
Private Sub CmdBeforeAfterCmp_Click()
On Error GoTo Exception

    Call SetOffscreenStart

    Set Before = Sheets("更新前")
    Set After = Sheets("更新後")
    Set Cmp = Sheets("比較")

    'クリア
    Call Clear

    '何列目まで主キーか求める。
    PkeyCol = GetPkeyCol()
    If PkeyCol = -1 Then
        Cmp.Range("A1").Select
        Call SetOffscreenStop

        Exit Sub
    End If

    Dim BeforePKey As String
    Dim AfterPKey As String
    Dim BeforeRowIdx As Integer
    Dim AfterRowIdx As Integer
    Dim CmpRowIdx As Integer

    BeforeRowIdx = 4
    AfterRowIdx = 4
    CmpRowIdx = 4

    BeforePKey = MakePKey(Before, BeforeRowIdx) '更新前主キーを;で連結する
    AfterPKey = MakePKey(After, AfterRowIdx) '更新後主キーを;で連結する

    Call CopyPasteRow(Before, 3, Cmp, 3)

    'オートフィルタをセットする。
    Cmp.Range("A3").Select
    Selection.AutoFilter

    '行ループ
    Do While True
        '終了条件
        If Before.Cells(BeforeRowIdx, START_COL) = "" And _
                After.Cells(AfterRowIdx, START_COL) = "" Then
            Exit Do
        End If

        If Before.Cells(BeforeRowIdx, START_COL) = "" Then
            '更新前のレコードを最後まで読み終えた場合（更新後のレコードが更新前に存在しない場合（追加された場合））

            Call CopyPasteRow(After, AfterRowIdx, Cmp, CmpRowIdx) '更新後のレコードをセットする

            Selection.Interior.ColorIndex = 38 'ピンクにする
            Cmp.Cells(CmpRowIdx, ATTRIBUTE_COL) = "INS"

            AfterRowIdx = AfterRowIdx + 1 '更新後シートの行を進める
            AfterPKey = MakePKey(After, AfterRowIdx) '更新後主キーを;で連結する

        ElseIf After.Cells(AfterRowIdx, START_COL) = "" Then
             '更新後のレコードを最後まで読み終えた場合（更新前のレコードが更新後に存在しない場合（削除された場合））

            Call CopyPasteRow(Before, BeforeRowIdx, Cmp, CmpRowIdx) '更新前のレコードをセットする

            Selection.Interior.ColorIndex = 15 '灰色にする
            Cmp.Cells(CmpRowIdx, ATTRIBUTE_COL) = "DEL"

            BeforeRowIdx = BeforeRowIdx + 1 '更新前シートの行を進める
            BeforePKey = MakePKey(Before, BeforeRowIdx) '更新前主キーを;で連結する

        Else
            If BeforePKey < AfterPKey Then
                 '更新前のレコードが更新後に存在しない場合（削除された場合）

                Call CopyPasteRow(Before, BeforeRowIdx, Cmp, CmpRowIdx) '更新前のレコードをセットする

                Selection.Interior.ColorIndex = 15 '灰色にする
                Cmp.Cells(CmpRowIdx, ATTRIBUTE_COL) = "DEL"

                BeforeRowIdx = BeforeRowIdx + 1 '更新前シートの行を進める
                BeforePKey = MakePKey(Before, BeforeRowIdx) '更新前主キーを;で連結する

            ElseIf BeforePKey > AfterPKey Then
                '更新後のレコードが更新前に存在しない場合（追加された場合）

                Call CopyPasteRow(After, AfterRowIdx, Cmp, CmpRowIdx) '更新後のレコードをセットする

                Selection.Interior.ColorIndex = 38 'ピンクにする
                Cmp.Cells(CmpRowIdx, ATTRIBUTE_COL) = "INS"

                AfterRowIdx = AfterRowIdx + 1 '更新後シートの行を進める
                AfterPKey = MakePKey(After, AfterRowIdx) '更新後主キーを;で連結する

            Else
                '一致する場合

                Call CopyPasteRow(After, AfterRowIdx, Cmp, CmpRowIdx) '更新後のレコードをセットする

                Dim ColIdx As Integer
                ColIdx = START_COL

                '列に対するループ、値が更新されているかチェックしていく
                Do While True
                    '終了条件
                    If Before.Cells(3, ColIdx) = "" Then
                        Exit Do
                    End If

                    '一致しない場合（更新されている場合）
                    If Before.Cells(BeforeRowIdx, ColIdx) <> Cmp.Cells(CmpRowIdx, ColIdx) Then
                        Cmp.Cells(CmpRowIdx, ColIdx).Select
                        Selection.Interior.ColorIndex = 36 '黄色にする

                        Cmp.Cells(CmpRowIdx, ATTRIBUTE_COL) = "UPD"

                        Call CsllsAddComment(CmpRowIdx, ColIdx, _
                            Before.Cells(BeforeRowIdx, ColIdx), Cmp.Cells(CmpRowIdx, ColIdx), _
                            AfterPKey)
                    End If

                    ColIdx = ColIdx + 1

                Loop '列ループ

                BeforeRowIdx = BeforeRowIdx + 1 '更新前シートの行を進める
                BeforePKey = MakePKey(Before, BeforeRowIdx) '更新前主キーを;で連結する

                AfterRowIdx = AfterRowIdx + 1 '更新後シートの行を進める
                AfterPKey = MakePKey(After, AfterRowIdx) '更新後主キーを;で連結する
            End If
        End If

        CmpRowIdx = CmpRowIdx + 1 '比較シートの行を進める

    Loop '行ループ

    Call SetOffscreenStop

    Exit Sub

'例外処理
Exception:
    MsgBox "エラー内容:" & Err.Description, vbOKOnly, "異常終了"

    Call SetOffscreenStop

End Sub

'比較シートをクリアする
Private Sub Clear()
    Cmp.Cells.Select
    Range("C29").Activate
    Selection.ClearContents
    Selection.Interior.ColorIndex = xlNone

    Call CellsClearComments
End Sub

'セルにコメントを付加する。
Private Sub CsllsAddComment(ByVal row As Integer, ByVal col As Integer, ByVal updBefore As String, ByVal updAfter As String, ByVal priKey As String)
    Cmp.Cells(row, col).AddComment
    Cmp.Cells(row, col).Comment.Text Text:="主キー：" & priKey & Chr(10) & "変更前：" & updBefore & Chr(10) & "変更後：" & updAfter

    Cmp.Cells(row, col).Comment.Visible = True  'Shapeを変更したいためtrueにする。
    Cmp.Cells(row, col).Select                  'セルを選択する
    Selection.Comment.Shape.Select True         'コメントを選択する『=』はいらない
    Selection.AutoSize = True                   'AutoSizeを有効にする
    Selection.ShapeRange.IncrementLeft -100
    Cmp.Cells(row, col).Comment.Visible = False '非表示にする。

End Sub

'セル上すべてのコメントをクリアする。
Private Sub CellsClearComments()
    Cmp.Cells.Select
    Selection.ClearComments
    Cmp.Cells(1, 1).Select
End Sub

'更新前シートから、何列目まで主キーか求める。
Private Function GetPkeyCol() As Integer
    Dim PkeyCol As Integer

    Dim i As Integer
    For i = START_COL To 255
        '終了条件
        If Before.Cells(3, i) = "" Then
            Exit For
        End If

        '終了条件（下線では無い場合）
        If Before.Cells(3, i).Font.Underline <> xlUnderlineStyleSingle Then
            Exit For
        End If
    Next

    '主キーが設定されていない場合はエラー
    If i = START_COL Then
        MsgBox "主キーの列名の書式を下線にしてください。", vbOKOnly, "エラー"
        i = 0
    End If

    PkeyCol = i - 1 '主キー列

    GetPkeyCol = PkeyCol
End Function

'プライマリーキーを;で連結して返す
Private Function MakePKey(ByRef sheet As Worksheet, ByVal rowIdx As Integer) As String
    Dim wkStr As String
    wkStr = ""

    Dim i As Integer
    For i = START_COL To PkeyCol
        wkStr = wkStr & sheet.Cells(rowIdx, i) & ";"
    Next

    MakePKey = wkStr

End Function

'第１引数で指定したコピー元のワークシートの行を
'第３引数で指定したコピー先のワークシートの行にコピーする。
Private Sub CopyPasteRow( _
        ByRef Sheet1 As Worksheet, ByVal rowIdx1 As Integer, _
        ByRef Sheet2 As Worksheet, ByVal rowIdx2 As Integer)

    Sheet1.Select
    Sheet1.Rows(rowIdx1 & ":" & rowIdx1).Select
    Selection.Copy
    Sheet2.Select
    Sheet2.Rows(rowIdx2 & ":" & rowIdx2).Select
    ActiveSheet.Paste
End Sub

★モジュールファイルに記述
Option Explicit

'''
'''再計算および再描画を無効にする
'''
Public Sub SetOffscreenStart()
    Application.Cursor = xlWait
    Application.StatusBar = "処理中..."
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
End Sub

'''
'''再計算および再描画の無効を止める
'''
Public Sub SetOffscreenStop()
    Application.Cursor = xlDefault
    Application.StatusBar = ""
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

実装時のシートの状態
A列は、空けておく。
3行目はヘッダー
4行目から明細

ブックの構成
    シートは３つ用意する
    ★更新前シート
    ★更新後シート
    ★比較シート

    モジュールを１つ
    ★モジュールファイル

・検索キーワード：　Excel,　VBA

戻る　マイリストへ追加　　　