[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『表を比較し差分に色付け 追加です』（MMM）
以前、下記の条件を元にコードを作成していただきました。
下記内容で作成したいと思っています。
A列(ID)
B列(氏名)
・２つの同一様式のA列(ID)をキーにして比較、B列以降の値が異なるセルに背景色をつける。
・シートはSheet1(比較元)とSheet2(比較先)
・スタート位置はA3セル〜N列、最終行は都度変化、2つのシートの行数も異なる
・Sheet1のZ3セル以降に「○○セルが一致しましせん。Sheet1の値『●』に対し、Sheet2の値『△』です」の差分詳細を表示
更に数点条件を追加したく再度相談させてもらいました。
＜追加＞
・Sheet1とSheet2のB列(氏名)が違うのに、Sheet1とSheet2のA列(ID)が同じ場合はA列(ID)を赤文字にして「<該当行>のIDが不正です」(複数になる場合あり)のメッセージを出す
・Sheet1とSheet2のA列(ID)が重複していればA列(ID)を赤文字にして「「<該当行>のIDが重複しています」(複数になる場合あり)のメッセージを出す
どうぞよろしくお願い致します。
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
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
Sub main()
Dim c As Range, s1 As Worksheet, s2 As Worksheet, dic1 As Object, dic2 As Object, k, msg As String, i As Long
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Cells.Interior.Color = xlNone
s2.Cells.Interior.Color = xlNone
s1.Range("Z:Z").ClearContents
For Each c In Intersect(s1.UsedRange, s1.Range("A:A"))
If WorksheetFunction.CountIf(s1.Range("A:A"), c.Value) > 1 Then
dic1(c.Value) = "ID重複"
Else
If c.Value = "" Then
c.Value = "新規"
Else
dic1(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13))
End If
End If
Next c
For Each c In Intersect(s2.UsedRange, s2.Range("A:A"))
If WorksheetFunction.CountIf(s2.Range("A:A"), c.Value) > 1 Then
dic1(c.Value) = "ID重複": c.Interior.Color = vbRed
Else
dic2(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13))
End If
Next c
For Each k In dic1
msg = "": col = ""
If dic1(k) = "ID重複" Then
msg = msg & "ID重複"
Else
Select Case dic2(k)
Case ""
msg = "Sheet2にIDなし"
dic1(k) = msg
Case Is <> dic1(k)
For i = 0 To UBound(Split(dic2(k), Chr(2)))
If Split(dic2(k), Chr(2))(i) <> Split(dic1(k), Chr(2))(i) Then
If i > 0 Then
msg = msg & "Sheet1の値『" & Split(dic1(k), Chr(2))(i) & "』に対しSheet2の値『" & Split(dic2(k), Chr(2))(i) & "』"
col = col & Chr(1) & i
Else
msg = msg & "ID不正"
col = col & Chr(1) & i
End If
End If
Next i
dic1(k) = msg & col
End Select
End If
If msg = "" Then dic1(k) = ""
Next k
For Each c In Intersect(s1.UsedRange, s1.Range("A:A"))
If dic1(c.Value) = "ID重複" Then
c.Interior.Color = vbRed
c.Offset(, 25).Value = "ID重複"
ElseIf InStr(dic1(c.Value), "ID不正") > 0 Then
c.Interior.Color = vbRed
c.Offset(, 25).Value = "ID不正"
Else
If InStr(dic1(c.Value), Chr(1)) > 0 Then
c.Offset(, 25).Value = Mid(dic1(c.Value), 1, InStr(dic1(c.Value), Chr(1)) - 1)
For i = 1 To UBound(Split(dic1(c.Value), Chr(1)))
c.Offset(, Split(dic1(c.Value), Chr(1))(i) + 1).Interior.Color = vbGreen
Next i
Else
c.Offset(, 25).Value = dic1(c.Value)
End If
End If
Next c
End Sub
（mm） 2023/12/19(火) 16:41:30
こちらを解消できれば完璧です。
お早い回答を貰えてたすかります。
（MMM） 2023/12/19(火) 16:57:07
上記の２点については修正を行いました。
最初の要件で
＞・Sheet1とSheet2のB列(氏名)が違うのに、Sheet1とSheet2のA列(ID)が同じ場合はA列(ID)を赤文字にして「<該当行>のIDが不正です」(複数になる場合あり)のメッセージを出す
と記載しておりました。
B列→C列にする場合はどこをどのように修正すればよいのか教えてください。
何度もコードを読もうとしたのですが理解できずにまた頼ってしまいました。
申し訳ございませんがよろしくおねがいします。
（MMM） 2023/12/20(水) 14:16:52
どのコードがどの処理かコメントが頂ければ、大変勉強になります。
（MMM） 2023/12/20(水) 15:26:58
Sub main()
' 変数の宣言
Dim c As Range, s1 As Worksheet, s2 As Worksheet, dic1 As Object, dic2 As Object, k, msg As String, i As Long
' Scripting.Dictionary オブジェクトの作成
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
' シートの設定
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
' シートの背景色をクリア
s1.Cells.Interior.Color = xlNone
s2.Cells.Interior.Color = xlNone
' シート1の列Zをクリア
s1.Range("Z:Z").ClearContents
' シート1の処理
For Each c In Intersect(s1.UsedRange, s1.Range("A:A"))
' IDの重複をチェック
If WorksheetFunction.CountIf(s1.Range("A:A"), c.Value) > 1 Then
dic1(c.Value) = "ID重複"
Else
' IDが空の場合とそれ以外の場合で処理を分岐
If c.Value = "" Then
c.Value = "新規"
Else
dic1(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13))
End If
End If
Next c
' シート2の処理
For Each c In Intersect(s2.UsedRange, s2.Range("A:A"))
' IDの重複をチェック
If WorksheetFunction.CountIf(s2.Range("A:A"), c.Value) > 1 Then
dic1(c.Value) = "ID重複": c.Interior.Color = vbRed
Else
dic2(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13))
End If
Next c
' Dictionary1の各要素に対して比較とメッセージの設定
For Each k In dic1
msg = "": col = ""
If dic1(k) = "ID重複" Then
msg = msg & "ID重複"
Else
Select Case dic2(k)
Case ""
msg = "Sheet2にIDなし"
dic1(k) = msg
Case Is <> dic1(k)
' シート1とシート2の値を比較し、差異があればメッセージを設定
For i = 0 To UBound(Split(dic2(k), Chr(2)))
If Split(dic2(k), Chr(2))(i) <> Split(dic1(k), Chr(2))(i) Then
If i > 0 Then
msg = msg & "Sheet1の値『" & Split(dic1(k), Chr(2))(i) & "』に対しSheet2の値『" & Split(dic2(k), Chr(2))(i) & "』"
col = col & Chr(1) & i
Else
msg = msg & "ID不正"
col = col & Chr(1) & i
End If
End If
Next i
dic1(k) = msg & col
End Select
End If
' 空の場合はメッセージをクリア
If msg = "" Then dic1(k) = ""
Next k
' 結果の表示と背景色の設定
For Each c In Intersect(s1.UsedRange, s1.Range("A:A"))
If dic1(c.Value) = "ID重複" Then
c.Interior.Color = vbRed
c.Offset(, 25).Value = "ID重複"
ElseIf InStr(dic1(c.Value), "ID不正") > 0 Then
c.Interior.Color = vbRed
c.Offset(, 25).Value = "ID不正"
Else
If InStr(dic1(c.Value), Chr(1)) > 0 Then
' カラムの位置情報を取得し、表示および背景色の設定
c.Offset(, 25).Value = Mid(dic1(c.Value), 1, InStr(dic1(c.Value), Chr(1)) - 1)
For i = 1 To UBound(Split(dic1(c.Value), Chr(1)))
c.Offset(, Split(dic1(c.Value), Chr(1))(i) + 1).Interior.Color = vbGreen
Next i
Else
' 差異がない場合はメッセージを表示
c.Offset(, 25).Value = dic1(c.Value)
End If
End If
Next c
End Sub
（取り急ぎ） 2023/12/20(水) 15:33:44
心より感謝します。
（MMM） 2023/12/20(水) 15:49:37
For i = 0 To UBound(Split(dic2(k), Chr(2)))
If Split(dic2(k), Chr(2))(i) <> Split(dic1(k), Chr(2))(i) Then
if i > 0 Then
msg = msg & "今年度結果の値『" & Split(dic1(k), Chr(2))(i) & "』に対し前年度結果の値『" & Split(dic2(k), Chr(2))(i) & "』"
col = col & Chr(1) & i
Else
msg = msg & "ID不正"
col = col & Chr(1) & i
End If
End If
Next i
（MMM） 2023/12/20(水) 16:08:25
Chr(2)は区切り文字なので、2は関係ありません。
dic1(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13)) dic2(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13))
この辺りのc.Offset(,1)の1を2にするのかなとは思いますが、全体の整合性までは見ていません。 （ゆたか） 2023/12/20(水) 16:37:11
Chr(2)、質問した後に更に調べたところ全く関係のないコード部分と知りました。
無知でお恥ずかしいです。
（MMM） 2023/12/20(水) 16:51:32
dic1(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13)) dic2(c.Value) = WorksheetFunction.TextJoin(Chr(2), False, c.Offset(, 1).Resize(, 13))
c.Offset(,1)の1を2に変えたところ、他のチェック列がずれるようになってしまいました。
誤)Sheet1とSheet2のB列(氏名)が違う場合、Sheet1とSheet2のA列(ID)が同じ場合はA列(ID)を赤文字にして「<該当行>のIDが不正です」(複数になる場合あり)のメッセージを出す
正)誤)Sheet1とSheet2のC列(氏名)が違う場合、Sheet1とSheet2のA列(ID)が同じ場合はA列(ID)を赤文字にして「<該当行>のIDが不正です」(複数になる場合あり)のメッセージを出す
に修正する場合を教えてもらえますでしょうか。よろしくお願いします。
（MMM） 2023/12/21(木) 09:17:07
まだまだ無知ですが、しっかり勉強していきたいと思います。
ご回答いただいたみなさま、ありがとうございました。
（MMM） 2023/12/21(木) 10:58:57
緑色がずれるってことでしょうか？
c.Offset(, Split(dic1(c.Value), Chr(1))(i) + 1).Interior.Color = vbGreen
これを
c.Offset(, Split(dic1(c.Value), Chr(1))(i) + 2).Interior.Color = vbGreen
でどうでしょうか？
また、動いているなら良いとも言えますが、
Dim c As Range, s1 As Worksheet, s2 As Worksheet, dic1 As Object, dic2 As Object, k, msg As String, i As Long
ではcolが定義されていないので、
Dim c As Range, s1 As Worksheet, s2 As Worksheet, dic1 As Object, dic2 As Object, k, msg As String, col As String, i As Long （ゆたか） 2023/12/21(木) 11:30:42
解決したならそう明記したほうがいいですよ。 [[20231215092241]] のように、これから動かしてみます、で返事したことにして、 結果報告もテキトーな人だから仕方がないけど。 （xyz） 2023/12/21(木) 11:47:20
ゆたかさん、ありがとうございます。頂いた内容ではやはり緑がずれてしまいました。
むさんの内容では正しく動きました。
頂いたコードで試験しており、解決まで行き届かずご報告できておりませんでした。
長々とお教えいただいたのに、失礼をお許しください。
ありがとうございました。
（MMM） 2023/12/21(木) 16:30:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.