| |
改良版です。
整理と追加をしてみました。
マスターの重複もチェックしています。
Sheet1が転記用シートです。
Sheet2がマスターです。
=====================================================
Sheet1モジュールに
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim EndC2 As Range, rng2 As Range
Dim r As Range
Dim 行 As Long
'
行 = Target.Row
If Target.Count > 1 Then Exit Sub
If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
If Cells(行, "A").Value = "" Then del 行: Exit Sub
If Cells(行, "K").Value = "" Then del 行: Exit Sub
'
Set EndC2 = Sheets("Sheet2").Range("A65536").End(xlUp)
Set rng2 = Sheets("Sheet2").Range("A2", EndC2) 'データ範囲（参照元）
'
For Each r In Range("A2", Range("A65536").End(xlUp))
If r.Row <> 行 Then
If Cells(行, "A").Value & Cells(行, "K").Value = _
Cells(r.Row, "A").Value & Cells(r.Row, "K").Value Then
Beep
MsgBox "重複"
del 行
Target.ClearContents
Target.Select
GoTo Jump
End If
End If
Next
'
del 行
Application.EnableEvents = False
For Each r In rng2
If r.Value & r.Offset(, 10).Value = _
Cells(行, "A").Value & Cells(行, "K").Value Then
Cells(行, "M").Resize(, 2).Value = r.Offset(, 12).Resize(, 2).Value
Exit For
End If
Next
Application.EnableEvents = True
'
Jump:
Set rng2 = Nothing
Set EndC2 = Nothing
End Sub
Private Sub del(r As Long)
Range(Cells(r, "m"), Cells(r, "n")).ClearContents
End Sub
===========================================================
Sheet2モジュールに
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim 行 As Long
行 = Target.Row
If Target.Count > 1 Then Exit Sub
If (Target.Column - 1) * (Target.Column - 11) <> 0 Then Exit Sub
If Cells(行, "A").Value = "" Then Exit Sub
If Cells(行, "K").Value = "" Then Exit Sub
'
For Each r In Range("A2", Range("A65536").End(xlUp))
If r.Row <> 行 Then
If Cells(行, "A").Value & Cells(行, "K").Value = _
Cells(r.Row, "A").Value & Cells(r.Row, "K").Value Then
Beep
MsgBox "重複"
Target.ClearContents
Target.Select
Exit For
End If
End If
Next
End Sub
|
|
kobasan
- 05/9/10(土) 10:36 -
