|
おはようございます。
以下のように変更してください。
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:
' 記号がDのときは、各項目比較は要らないのですか?
.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
プログラムって数学の数列のように規則性を見出せば、
ループ処理が使えますからね!!
(複雑なものはこれが発見できるか否かがキーポイントになります)
取り合えず、Sheet1のデータがSheet2に存在した場合、
しかも記号が A 又は、U の場合、
Sheet1とSheet2の項目1から項目8を比較
して一致しないセルのマスタ側のセルを赤く塗りつぶす
処理は出来ています。
試してみてください。
|
|