| |
まず初めに・・
Sub Data_Copy()
With Sheets("Sheet2")
Sheets("Sheet1").Range("X24:X65536").SpecialCells(2) _
.Copy .Range("E23")
With .Range("E23", .Range("E65536").End(xlUp))
.Replace "監督人", 1
.SpecialCells(2, 1).Delete xlShiftUp
End With
.Activate
End With
End Sub
↑これを"一回だけ"実行して下さい。
Sheet2のE23以下に、人名だけが並んでコピーされているのを確認し、
Sheet1 のシートモジュールに、以下のイベントマクロを入れて下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Mnm As String
If Intersect(Target, Range("Z23:Z65536")) Is _
Nothing Then Exit Sub
With Target
If .Count > 1 Then GoTo ELine
If IsEmpty(.Value) Then Exit Sub
If IsNumeric(.Value) Then GoTo ELine
If .Value = "監督人" Then Exit Sub '←追加
Mnm = .Value
End With
With Worksheets("Sheet2")
If Not IsError(Application.Match(Mnm, .Range("E:E"), 0)) Then
MsgBox "その名前は入力済みです", 48: GoTo ELine
End If
.Range("E65536").End(xlUp).Offset(1).Value = Mnm
End With
MsgBox Mnm & vbLf & "を転記しました", 64: Exit Sub
ELine:
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
