本文へスキップ

簡単!!エクセルVBAメモ

3.VBA応用(使用ケース集)

エクセル差分検知ツール


  テキストファイルでは、2つのファイルの差分を検出するツールがよくありますが、
  エクセルでも差分を見つけるのがほしくて作ってみました。

 【サンプル処理イメージ】
  @マクロを実行 ※比較するエクセル・シート情報などを事前に入力
  A2つのエクセルを開いて、A1セルから差分を抽出します。(指定の行数まで比較)
  B差分があったら、両方の値を出力する。


  【以下マクロを実行する上でのエクセルの書式など】
  (1)操作画面ページ
 
    
  (2)比較ファイル1(上)、2(下)の内容 ※一部内容が異なる
  

   

  (3)実行結果 ※差分があるセルに2つのファイルに入っている内容が表示される
   



VBAサンプル
=========================================================
=== 開始!!================================================
=========================================================

Sub 差分抽出マクロ()

'**************************************************
'***  【概要】
'***    指定した2つのエクセル(シート)の差分を出す
'**************************************************

'*************************************************************
'***  1.定義
'*************************************************************
   '分割用
    Dim Spt() As String
    Dim S As String
   'ファイル名
    Dim new_name As String
    Dim old_name As String
   '縦横
    Dim tate As Variant
    Dim yoko As Variant
   'カウント
    Dim cnt As Variant

'*************************************************************
'***  2.初期処理
'*************************************************************
   '画面非表示
    Application.ScreenUpdating = False

   '@WK・結果用のシートをクリアする。
    Sheets("新").Select
    Selection.Delete Shift:=xlUp
    Sheets("旧").Select
    Selection.Delete Shift:=xlUp
    Sheets("差分結果").Select
    Selection.Delete Shift:=xlUp

   '入力値の設定
    Sheets("メイン").Select
    new_ex = Cells(6, "D")
    nex_sh = Cells(7, "D")

    old_ex = Cells(10, "D")
    old_sh = Cells(11, "D")

    tate_max = Cells(14, "D")
    yoko_max = Cells(15, "D")

   'ファイル名の取得(NEWとOLD共に)
    S = new_ex
    Spt = Split(S, "\")
    Max = UBound(Spt)
    new_name = Spt(Max)
    S = old_ex
    Spt = Split(S, "\")
    Max = UBound(Spt)
    old_name = Spt(Max)


'*************************************************************
'***  3.メイン処理
'*************************************************************

   '@エクセルを開く
    Workbooks.Open FileName:=new_ex
    Workbooks.Open FileName:=old_ex
    
   'A新のコピー処理
     '***コピー
    Windows(new_name).Activate
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
     '***貼り付け
    Windows("エクセル差分抽出.xlsm").Activate
    Sheets("新").Select
    Cells.Select
    ActiveSheet.Paste
    
   'B旧のコピー処理
     '***コピー
    Windows(old_name).Activate
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
     '***貼り付け
    Windows("エクセル差分抽出.xlsm").Activate
    Sheets("旧").Select
    Cells.Select
    ActiveSheet.Paste
    
   'C必要ないので閉じる。
    Application.CutCopyMode = False '※事前にクリップボードの情報をクリアしておく
    Workbooks(new_name).Close SaveChanges:=False
    Workbooks(old_name).Close SaveChanges:=False

   'D差の確認(A1から、指定の行列をチェックする
    tate = 1
    yoko = 1
    cnt = 0

    Do Until tate > tate_max
       yoko = 1
       Do Until yoko > yoko_max
         '差分の判定
          If Sheets("新").Cells(tate, yoko) = Sheets("旧").Cells(tate, yoko) Then
             Else
                Sheets("差分結果").Cells(tate, yoko) = Sheets("新").Cells(tate, yoko) & "【【←(新)||(旧)→】】" & Sheets("旧").Cells(tate, yoko)
                cnt = cnt + 1
          End If
          yoko = yoko + 1
       Loop
       tate = tate + 1
    Loop

   'E結果(差分数)の出力
    Sheets("メイン").Select
    Cells(18, "D") = cnt
    Cells(1, "A").Select

   'F終了処理(画面を表示して、結果を表示)
    Application.ScreenUpdating = True
    MsgBox ("差分件数:" & cnt & "件になります")
End Sub

=========================================================
=== 終了!!================================================
=========================================================





  トップページへ戻る