[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『表を比較し色付け、差分を表示』（MMM）
２つの同一の表を比較し、値が異なるセルに背景色をつけたいと思います。
シートはSheet1(比較元)とSheet2(比較先)、スタート位置はA3セル〜N列、最終行は都度変化、2つのシートの行数も異なります。
Sheet1のZ3セル以降に「○○セルが一致しましせん。Sheet1の値『●』に対し、Sheet2の値『△』です」の差分詳細を表示したいです。
参考に下記のコードをネットから探しだしましたが、うまく改造できませんでした。
上記条件にあった内容に修正のお力をいただけませんでしょうか。
Sub sabun()
Dim arrHikakuMotoHani As Variant
Dim arrHikakuSakiHani As Variant
Dim strHikakuMotoSheet As String
Dim strHikakuSakiSheet As String
Dim strHikakuRange As String
Dim strExpCol As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
strHikakuMotoSheet = "Sheet1"
strHikakuSakiSheet = "Sheet2"
strHikakuRange = "A3:N"
strExpCol = "Z"
k = 3
l = 0
arrHikakuMotoHani = Sheets(strHikakuMotoSheet).Range(strHikakuRange)
arrHikakuSakiHani = Sheets(strHikakuSakiSheet).Range(strHikakuRange)
Sheets(strHikakuMotoSheet).Range(strHikakuRange).Interior.Pattern = xlNone
Sheets(strHikakuMotoSheet).Range(strExpCol & k & ":" & strExpCol & "100000").ClearContents
For i = LBound(arrHikakuMotoHani, 1) To UBound(arrHikakuMotoHani, 1)
For j = LBound(arrHikakuMotoHani, 2) To UBound(arrHikakuMotoHani, 2)
If Not arrHikakuMotoHani(i, j) = arrHikakuSakiHani(i, j) Then
Sheets(strHikakuMotoSheet).Cells(k + i - 1, j).Interior.Color = 5287936 '緑
Sheets(strHikakuMotoSheet).Range(strExpCol & (k + l)).Value = Cells(i, j).Address _
& "が一致しません！" & strHikakuMotoSheet & "シートの値" & arrHikakuMotoHani(i, j) & "に対して" & strHikakuSakiSheet & "シートの値は" & arrHikakuSakiHani(i, j) & "です！"
l = l + 1
End If
Next
Next
End Sub
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
よろしくお願いいたします。
（MMM） 2023/12/15(金) 10:31:45
Dim r As Long: r = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
strHikakuRange = strHikakuRange & r
とか置いたら一応動きはしそう
（む） 2023/12/15(金) 17:00:11
＞２つの同一の表を比較し、値が異なるセルに背景色をつけたいと思います
~~~~~~~~~~~~~~~~
＞最終行は都度変化、2つのシートの行数も異なります。
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
２つの表の列範囲は一緒だと思うけど...Sheet1(比較元)にあるIDと
Sheet2(比較先)のIDのある行が違うってことはあるんですか？
また、Sheet1(比較元)にはIDがあるが、Sheet2(比較先)にはIDが無かったり するんですか？ （あみな） 2023/12/15(金) 17:14:30
Sub Sabun2()
'前提:比較元と比較先の列が同じ
'変数宣言/設定
Dim wsMoto As Worksheet, wsSaki As Worksheet 'ワークシート
Set wsMoto = ThisWorkbook.Worksheets("Sheet1") '比較元ワークシート
Set wsSaki = ThisWorkbook.Worksheets("Sheet2") '比較先ワークシート
Dim strCols As String: strCols = "A:N" '指定列範囲(文字列)
Dim iRow As Long: iRow = 3 '指定範囲開始行番号
Dim Col As String: Col = "Z" '差分詳細を表示する列
Dim k As Long: k = 3 '差分詳細の開始行番号
Dim r As Long: r = wsMoto.Cells(Rows.Count, 1).End(xlUp).Row '処理対象最終行番号(比較元のA列を参照)
Dim arrMoto As Variant, arrSaki As Variant '配列
arrMoto = wsMoto.Columns(strCols).Rows(iRow & ":" & r) '比較元範囲
arrSaki = wsSaki.Columns(strCols).Rows(iRow & ":" & wsSaki.Cells(Rows.Count, 1).End(xlUp).Row) '比較元範囲
'比較する配列の2次元目を拡張(ID存在チェック用)
ReDim Preserve arrMoto(LBound(arrMoto, 1) To UBound(arrMoto, 1), LBound(arrMoto, 2) To UBound(arrMoto, 2) + 1)
ReDim Preserve arrSaki(LBound(arrSaki, 1) To UBound(arrSaki, 1), LBound(arrSaki, 2) To UBound(arrSaki, 2) + 1)
'表の準備
wsMoto.Columns(strCols).Rows(iRow & ":" & r).Interior.Pattern = xlNone 'セルの背景色･パターンをクリア
wsMoto.Range(Col & k & ":" & Col & 100000).ClearContents '差分詳細表示エリアの文字をクリア
'ループ用変数
Dim i As Long, j As Long, o As Long
'Dim n As Long: n = 2 '配列からセル位置にするときに加算する数(指定範囲開始行番号 - 1)
Dim n As Long: n = iRow - LBound(arrMoto, 1) '配列からセル位置にするときに加算する数
For i = LBound(arrMoto, 1) To UBound(arrMoto, 1) '比較元行ループ
For o = LBound(arrSaki, 1) To UBound(arrSaki, 1) '比較先行ループ
'比較元と比較先のIDが同じ場合
If arrMoto(i, 1) = arrSaki(o, 1) Then
'ID存在チェックを入れる
arrMoto(i, UBound(arrMoto, 2)) = "OK"
arrSaki(o, UBound(arrSaki, 2)) = "OK"
For j = LBound(arrMoto, 2) To UBound(arrMoto, 2) '列ループ
'比較元と比較先で、同じ列の内容が異なる場合
If Not arrMoto(i, j) = arrSaki(o, j) Then
'比較元のセルの色を変更
wsMoto.Cells(i + 2, j).Interior.Color = 5287936 '緑 =RGB(0,176,80)
'詳細表示設定
wsMoto.Range(Col & k).Value = wsMoto.Cells(i + n, j).Address _
& "が一致しません！" & wsMoto.Name & "シートの値" & arrMoto(i, j) & "に対して" & wsSaki.Name & "シートの値は" & arrSaki(i, j) & "です！"
k = k + 1
End If
Next j
End If
Next o
Next i
'ID存在チェックの結果を確認
For i = LBound(arrMoto, 1) To UBound(arrMoto, 1) '比較元ループ
'ID存在チェックが出来ていない場合
If Not arrMoto(i, UBound(arrMoto, 2)) = "OK" Then
'A列~N列のセルの色を設定
wsMoto.Range("A" & i + n & ":N" & i + n).Interior.Color = RGB(255, 128, 128) '赤っぽい色
'詳細表示設定
wsMoto.Range(Col & k).Value = "ID" & arrMoto(i, 1) & "が" & wsSaki.Name & "シートに存在しません！"
k = k + 1
End If
Next i
For o = LBound(arrSaki, 1) To UBound(arrSaki, 1) '比較先ループ
'ID存在チェックが出来ていない場合
If Not arrSaki(o, UBound(arrMoto, 2)) = "OK" Then
'比較元に追記する場合はコメントアウトを解除
' r = r + 1
' For j = LBound(arrSaki, 2) To UBound(arrSaki, 2)
' wsMoto.Cells(r, j).Value = arrSaki(o, j)
' Next j
' 'A列~N列のセルの色を設定
' wsMoto.Range("A" & r & ":N" & r).Interior.Color = RGB(255, 216, 112) '黄色っぽい色
'詳細表示設定
wsMoto.Range(Col & k).Value = "ID" & arrSaki(o, 1) & "が" & wsMoto.Name & "シートに存在しません！"
k = k + 1
End If
Next o
End Sub
（む） 2023/12/15(金) 18:43:02
こんな書き方もあります。
Option Explicit
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim pos As Long
Sub 差分チェック()
Dim dic As Object
Dim id As String
Dim s As String
Dim k As Long
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set dic = CreateObject("Scripting.Dictionary")
For k = 3 To ws2.Cells(Rows.Count, "A").End(xlUp).Row
s = ws2.Cells(k, "A")
If s <> "" Then dic(s) = k
Next
ws1.UsedRange.Interior.Pattern = xlNone
ws2.UsedRange.Interior.Pattern = xlNone
ws1.Cells(3, "Z").Resize(1, 5).EntireColumn.ClearContents
ws1.Cells(3, "Z").Resize(1, 5) = Array("ID", "Sheet1", "値", "Sheet2", "値")
pos = 4
For k = 3 To ws2.Cells(Rows.Count, "A").End(xlUp).Row
id = ws1.Cells(k, "A").Value
If id <> "" Then
If dic.Exists(id) Then
Call myCompare(k, dic(id))
Else
Debug.Print id & "がsheet2にありません"
End If
End If
Next
End Sub
'Sheet1のr1行と、Sheet2のr2行を比較
Function myCompare(r1 As Long, r2 As Long)
Dim col As Long
Dim ary1 As Variant
Dim ary2 As Variant
ary1 = ws1.Cells(r1, "A").Resize(1, 14).Value
ary2 = ws2.Cells(r2, "A").Resize(1, 14).Value
For col = 2 To 14
If ary1(1, col) <> ary2(1, col) Then
ws1.Cells(r1, col).Interior.Color = vbGreen
ws2.Cells(r2, col).Interior.Color = vbGreen
ws1.Cells(pos, "Z") = ary1(1, 1)
ws1.Cells(pos, "AA") = ws1.Cells(r1, col).Address
ws1.Cells(pos, "AB") = ary1(1, col)
ws1.Cells(pos, "AC") = ws2.Cells(r2, col).Address
ws1.Cells(pos, "AD") = ary2(1, col)
pos = pos + 1
End If
Next
End Function
（xyz） 2023/12/16(土) 13:17:48
あみな様
仰る通り、列範囲は同じで、元と先のIDのある行は異なります。
また、Sheet1にはあるIDもSheet2はなかったりします。
IDが空白の行もあるので、こちらについては「新規」と入力しエラーにならないようにできればと思っています。
xyz様
このような書き方もあるのですね、ありがとうございます。
こちらも動かしてみたいと思います。
（MMM） 2023/12/18(月) 14:45:50
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.