|
こんばんは。
こんなもんでいかがでしょう?
標準モジュールにコピペしてください。
シートの名前はそちらに合わせてください。
※品名と規格に重複がある場合は、一つ目は、そのまま転記
二つ目に、重複した値とアドレスを出すようにしています。
Sub test()
Dim SH1 As Worksheet, SH2 As Worksheet
Dim myR As Range, myR2 As Range
Dim r As Range, c As Range
Set SH1 = Worksheets("単価マスタ")
Set SH2 = Worksheets("代価表シート")
Set myR = SH1.Range("A2", SH1.Range("A65536").End(xlUp))
Set myR2 = SH2.Range("A2", SH2.Range("A65536").End(xlUp))
For Each r In myR2
t = 0
For Each c In myR
If r.Value = c.Value Then
If c.Offset(0, 10).Value = r.Offset(0, 1).Value Then
t = t + 1
If t > 1 Then
MsgBox "規格" & c.Offset(0, 10).Value & _
"(" & c.Offset(0, 10).Address(0, 0) & ")" & _
vbCrLf & "が重複しています"
Exit For
End If
r.Offset(0, 2).Value = c.Offset(0, 12).Value
r.Offset(0, 4).Value = c.Offset(0, 13).Value
End If
End If
Next
Next
End Sub
|
|