| |
Dictionary版です。
マスターの重複もチェックしています。
Sheet1が転記用シートです。
Sheet2がマスターです。
=====================================================
Sheet1モジュールに
Option Explicit
Private dicM As Object
Private Sub Worksheet_Deactivate()
Set dicM = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dic1 As Object
Dim 行 As Long
Dim vntA, vntK
Dim i As Long, LastR As Long, mr 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
'
If dicM Is Nothing Then make_dicM
LastR = Range("A65536").End(xlUp).Row
Set dic1 = CreateObject("Scripting.Dictionary")
vntA = Range("A2", Range("A" & LastR)).Value
vntK = Range("K2", Range("K" & LastR)).Value
For i = 1 To UBound(vntA)
If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
dic1(vntA(i, 1) & vntK(i, 1)) = dic1(vntA(i, 1) & vntK(i, 1)) + 1
End If
Next
'
If dic1(Cells(行, "A").Value & Cells(行, "K").Value) > 1 Then
MsgBox "重複"
del 行
Target.ClearContents
Target.Select
GoTo Jump
End If
'
del 行
Application.EnableEvents = False
mr = dicM(Cells(行, "A").Value & Cells(行, "K").Value)
If mr > 0 Then Cells(行, "M").Resize(, 2).Value = _
Sheets("Sheet2").Cells(mr, "M").Resize(, 2).Value
Application.EnableEvents = True
'
Jump:
Set dic1 = Nothing
End Sub
Private Sub del(r As Long)
Range(Cells(r, "m"), Cells(r, "n")).ClearContents
End Sub
Private Sub make_dicM()
Dim vntA, vntK
Dim i As Long, LastR As Long
Set dicM = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
LastR = .Range("A65536").End(xlUp).Row
vntA = .Range("A2", .Range("A" & LastR)).Value
vntK = .Range("K2", .Range("K" & LastR)).Value
For i = 1 To UBound(vntA)
If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
dicM(vntA(i, 1) & vntK(i, 1)) = i + 1
End If
Next
End With
End Sub
===========================================================
Sheet2モジュールに
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim dic2 As Object
Dim 行 As Long
Dim vntA, vntK
Dim i As Long, LastR 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
'
LastR = Range("A65536").End(xlUp).Row
Set dic2 = CreateObject("Scripting.Dictionary")
vntA = Range("A2", Range("A" & LastR)).Value
vntK = Range("K2", Range("K" & LastR)).Value
For i = 1 To UBound(vntA)
If vntA(i, 1) <> "" And vntK(i, 1) <> "" Then
dic2(vntA(i, 1) & vntK(i, 1)) = dic2(vntA(i, 1) & vntK(i, 1)) + 1
End If
Next
'
If dic2(Cells(行, "A").Value & Cells(行, "K").Value) > 1 Then
MsgBox "重複"
Target.ClearContents
Target.Select
End If
Set dic2 = Nothing
End Sub
|
|
kobasan
- 05/9/10(土) 10:40 -
