| |
シート比較、ご教授下さいm( _ _ )m
どなたかご教示下さい。
以下のようなSheet1とSheet2があります。
この２つのシートを比較して、Sheet3に比較結果を書き出します。
・現在、プログラムを実行すると【◆（求めている結果）】ではなく
【◆（現状出てしまう結果）】のアンマッチ結果が出てしまいます。
・（とらん）及び（ますた）のコード1とコード2が文字列である為、
アンマッチと出ていると思われます。
・（とらん）及び（ますた）のコード1とコード2の値を数値にすると
求めている結果となりました。
ｖｂａ初心者なもので、どなたかご教授頂けますでしょうか。
―――――――――――――――――――――――――――
◆（とらん）
A B C D E F G H I J K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|A001 101 A 1 1 1 1 1 1 1 1
3|B001 202 U 2 2 2 2 2 2 2 2
4|C001 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|A001 101 1 1 1 1 1 1 1 1
3|A001 101 1 1 1 1 1 1 1 1
3|B001 202 2 2 2 2 2 2 2 2
4|C001 303 3 3 3 3 3 3 3 3
◆（求めている結果）
1|Sheet コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1 A001 101 A 1 1 1 1 1 1 1 1
3|2 A001 101 1 1 1 1 1 1 1 1
4|1 B001 202 U 2 2 2 2 2 2 2 2
5|2 B001 202 2 2 2 2 2 2 2 2
6|1 C001 303 U 3 3 3 3 3 3 3 3
7|2 C001 303 3 3 3 3 3 3 3 3
-----------------------------------------------------------------------
◆（現状出てしまう結果）
1|Sheet コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1 A001 101 A 1 1 1 1 1 1 1 1
3|2 * *
4|1 B001 202 U 2 2 2 2 2 2 2 2
5|2 * *
6|1 C001 303 U 3 3 3 3 3 3 3 3
7|2 * *
―仕様――――――――――――――――――――――――――
１）「とらん」を１件づつ読込み、ｺｰﾄﾞ1とｺｰﾄﾞ2をキーに「ますた」を検索し、
『とらん』「記号」＝"A" OR "U" の場合
◆存在した場合、項目1〜8を比較し、「とらん」と「ますた」の情報を
[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, jdx 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
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
Select Case sh1rng(idx, 3).Value
Case "A", "U":
For jdx = 5 To 12
If .Cells(idx * 2, jdx).Value <> .Cells(idx * 2 + 1, jdx).Value Then
.Cells(idx * 2 + 1, jdx).Interior.ColorIndex = 3
End If
Next jdx
Case Else:
.Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
End Select
End If
End With
Next
End If
End Sub
-------------------------------
以上です。
それでは失礼致します。
|
|
ドルフィン
- 06/11/15(水) 18:46 -
