ここから本文です

EXCEL VBA 2シートの比較について 1つのブック内にある2つのシートを比較し ...

her********さん

2019/3/2720:10:58

EXCEL VBA 2シートの比較について

1つのブック内にある2つのシートを比較し
相違があるものには赤字をつけ、一致するものがないときは黄色で塗りつぶすマクロを考えております。

シート内のレイアウトが違ったりするため、私ではどうも上手く比較し色付け処理をすることが出来ませんでした。

相違点は基本的に1箇所で、多くても二箇所です。
Sheet1のデータとSheet2のデータはSheet2が正しいものとなっております。
日付含む4つのデータから比較し3箇所以上不一致、または1つも一致するものがない場合は黄色で塗りつぶしできたらと思っております。
また、どちらも同日の範囲をしたいと考えております。

かなり難しいとは思うのですが、皆様のお力添えを頂ければと思っております。
何卒宜しくお願い申し上げます。

参考のブックをおいておりますのでご覧頂ければと思います。

https://yahoo.jp/box/Jcr_oz


使用環境
Windows 7 Office 2007
Windows 7 Office 2010

補足他にも様々なアプローチや手段をご存知の方がいらっしゃれば是非回答頂ければと思います。
最もVBA勉強に参考になった方をベストアンサーに選ばせていただきます。
皆様のご助力をお待ちしております。
何卒宜しくお願い申し上げます。

閲覧数:
164
回答数:
1
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

kky********さん

2019/4/313:12:15

Sub Sample()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim i As Long, imax As Long
Dim j As Long, k As Long
Dim kdate As Date
Dim rng As Range
Dim ck As Variant
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
sh3.UsedRange.Clear
'Sheet2のデータをSheet3へ
With sh2
imax = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To imax
If .Range("A" & i) <> kdate Then
j = j + 1
kdate = .Range("A" & i)
End If
j = j + 1
.Range("A" & i & ":D" & i).Copy Destination:=sh3.Range("F" & j)
Next i
End With
Set rng = sh3.Range("F1:F" & sh3.Cells(Rows.Count, "F").End(xlUp).Row)
'Sheet1のデータをSheet3へ
With sh1
imax = .Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To imax
If .Range("A" & i) <> "" Then
ck = Application.Match(.Range("A" & i), rng, 0)
If IsError(ck) = False Then
sh3.Range("A" & ck - 1) = .Range("A" & i)
sh3.Range("A" & ck - 1).NumberFormatLocal = "yyyy/m/d"
j = ck - 1
i = i + 1
Do Until .Range("A" & i) <> "" Or i > imax
j = j + 1
.Range("B" & i & ":D" & i).Copy Destination:=sh3.Range("B" & j)
i = i + 1
Loop
i = i - 1
End If
End If
Next i
End With
'色つけ
With sh3
imax = .Cells(Rows.Count, "F").End(xlUp).Row
For i = 2 To imax
If .Range("B" & i) <> "" Then
Set rng = .Range("G" & i & ":G" & imax)
ck = Application.Match(.Range("B" & i), rng, 0)
If IsError(ck) Then
.Range("B" & i).Font.ColorIndex = 3
ElseIf .Range("C" & i).Value <> .Range("I" & ck + i - 1).Value Then
.Range("C" & i).Font.ColorIndex = 3
ElseIf .Range("D" & i).Value <> .Range("H" & ck + i - 1).Value Then
.Range("D" & i).Font.ColorIndex = 3
End If
End If
If .Range("F" & i) <> "" And .Range("B" & i) = "" Then
.Range("F" & i & ":I" & i).Interior.ColorIndex = 6
End If
Next i
End With
Application.ScreenUpdating = True
sh3.Select
End Sub

質問した人からのコメント

2019/4/3 19:50:19

このたびは本当にありがとうございました。
また多くのわがままを聞いてくださった心の広さに感服致します。
また機会がございましたら、何卒よろしくお願い申し上げます。

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる