| |
シート比較、ご教授下さいm( _ _ )m
どなたかご教示下さい。ｖｂａ初心者です。
以下のようなSheet1とSheet2があります。
この２つのシートを比較して、Sheet3に比較結果を書き出します。
ですが、以下に記載したプログラムを実行すると、結果[Sheet3]の
５、７行目の項目１〜８のセルの背景色が赤く表示されてしまいます。
結果の値の出力は仕様通り表示されています。
―――――――――――――――――――――――――――
◆（とらん）
A B C D E F G H I J K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1001 101 A 1 1 1 1 1 1 1 1
3|2001 202 U 2 2 2 2 2 2 2 2
4|3001 303 U 3 3 3 3 3 3 3 3
◆（ますた）
A B C D E F G H I J K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1001 101 1 1 1 1 1 1 1 1
3|1001 101 1 1 1 1 1 1 1 1
3|2001 202 2 2 2 2 2 2 2 2
4|3001 303 3 3 3 3 3 3 3 3
◆（結果）
1|Sheet コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1 1001 101 A 1 1 1 1 1 1 1 1
3|2 1001 101 1 1 1 1 1 1 1 1
4|1 2001 202 U 2 2 2 2 2 2 2 2
5|2 2001 202 2 2 2 2 2 2 2 2
6|1 3001 303 U 3 3 3 3 3 3 3 3
7|2 3001 303 3 3 3 3 3 3 3 3
―仕様――――――――――――――――――――――――――
１）「とらん」を１件づつ読込み、ｺｰﾄﾞ1とｺｰﾄﾞ2をキーに「ますた」を検索し、
『とらん』「記号」＝"A"の場合
◆存在した場合、項目1,2,3を比較し、「とらん」と「ますた」の情報を
[Sheet3]に結果を書き出します。
「ますた」に複数存在した場合は１件目のレコードで比較します。
アンマッチ項目があった場合、その項目のセルを赤く表示します。
◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
結果を書き出し、マスタのキーエリアに"*"を設定し、セルを赤く。
『とらん』「記号」＝"D"の場合
◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
結果を書き出し、「ますた」はキーエリアに"-"を設定します。
◆存在した場合、[Sheet3]に結果を書き出します。
「ますた」に複数存在した場合は１件目のレコードで比較します。
アンマッチ項目があった場合、その項目のセルを赤く表示します。
以上を「とらん」のレコードがなくなるまで繰り返します。
※「とらん」は十件程度です。「とらん」がゼロ件の場合は処理を行いません
----
どなたか解る方がいらっしゃいましたら、ご教授の程、宜しくお願い致します。
―プログラム――――――――――――――――――――――――――
Sub 実行()
Dim sh1rng As Range
Dim sh2rng As Range
Dim addA As String
Dim addB As String
Dim sh2strw As Long
Dim idx As Long
Dim rw As Variant
Dim nsign As String
'↓本文
With Worksheets("sheet1")
Set sh1rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
End With
If sh1rng.Row > 1 Then
With Worksheets("sheet2")
Set sh2rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
sh2strw = sh2rng.Row
If sh2strw > 1 Then
addA = sh2rng.Address(, , , True)
addB = sh2rng.Offset(0, 1).Address(, , , True)
End If
End With
For idx = 1 To sh1rng.Count
rw = CVErr(xlErrNA)
If sh2strw > 1 Then
rw = Evaluate("=match(1,(" & addA & "=" & sh1rng.Cells(idx) & _
")*(" & addB & "=" & sh1rng.Offset(0, 1).Cells(idx) & _
"),0)")
'↑検索
End If
With Worksheets("sheet3")
.Cells(idx * 2, 1).Value = 1
.Range(.Cells(idx * 2, 2), .Cells(idx * 2, 12)).Value = sh1rng(idx).Resize(, 11).Value
.Cells(idx * 2 + 1, 1).Value = 2
If IsError(rw) Then
Select Case sh1rng(idx, 3).Value
Case "D":
nsign = "-"
Case Else:
nsign = "*"
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
End Select
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Value = nsign
Else
Select Case sh1rng(idx, 3).Value
Case "A", "U":
If sh1rng(idx, 4).Value <> sh2rng(idx, 4).Value Then
.Range(.Cells(idx * 2 + 1, 5), .Cells(idx * 2 + 1, 5)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 5).Value <> sh2rng(idx, 5).Value Then
.Range(.Cells(idx * 2 + 1, 6), .Cells(idx * 2 + 1, 6)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 6).Value <> sh2rng(idx, 6).Value Then
.Range(.Cells(idx * 2 + 1, 7), .Cells(idx * 2 + 1, 7)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 7).Value <> sh2rng(idx, 7).Value Then
.Range(.Cells(idx * 2 + 1, 8), .Cells(idx * 2 + 1, 8)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 8).Value <> sh2rng(idx, 8).Value Then
.Range(.Cells(idx * 2 + 1, 9), .Cells(idx * 2 + 1, 9)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 9).Value <> sh2rng(idx, 9).Value Then
.Range(.Cells(idx * 2 + 1, 10), .Cells(idx * 2 + 1, 10)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 10).Value <> sh2rng(idx, 10).Value Then
.Range(.Cells(idx * 2 + 1, 11), .Cells(idx * 2 + 1, 11)).Interior.ColorIndex = 3
End If
If sh1rng(idx, 11).Value <> sh2rng(idx, 11).Value Then
.Range(.Cells(idx * 2 + 1, 12), .Cells(idx * 2 + 1, 12)).Interior.ColorIndex = 3
End If
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
Case Else:
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
End Select
End If
End With
Next
End If
End Sub
-----
以上です。
それでは失礼致します。
|
|
ドルフィン
- 06/11/12(日) 0:24 -
