Excel/VBA Worksheet_Changeを繰り返す

Question

私はworksheet_changeマクロを実行しています。私がそれをしたいのは、ある基準に合った別のワークブックの値をペーストするときにチェックすることです。たとえば、タイトル列である列A（A18で始まる）にエンドユーザーがペーストすると、タイトル列Cの下の別のワークシート「ドロップダウンメニュー」の値を満たさない限り、その値は拒否されます。ワークシート全体でいくつかの行が一致する必要があります。

A18、B18、A18の場合、A18の値が有効なタイトルではない場合、有効なタイトルである必要があります。 C18、D18、およびE18、およびE18が有効なタイプではない場合、それは戻ってA18が同様に有効でない私に指示。私はこれが偽= application.enable型ソリューションですが、それを把握することはできません感じる。

おかげ

Private Sub Worksheet_Change(ByVal Target As Range) 
'Insures values in column A are from Title List 
    Dim Title As Range 
    Set Title = Worksheets("DATA INPUT SHEET").Range("A18:A100000") 
    If Not Intersect(Target, Title) Is Nothing Then 
' 
     For Each c In Target 
      Set TitleLst = Worksheets("DROP DOWN MENUS").Range("C2:C1000").Find(c.Value, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) 
      If TitleLst Is Nothing And c <> "" Then 
       Application.EnableEvents = False 
       MsgBox "The value at " & c.Address(False, False) & " must be a valid " & Worksheets("DROP DOWN MENUS").Range("C1"), vbOKOnly + vbCritical 
       c.ClearContents 
       Application.EnableEvents = True 
      End If 
     Next 
    End If 
'Insures values in column E are from Recipient List 
    Dim Recipient As Range 
    Set Recipient = Worksheets("DATA INPUT SHEET").Range("E18:E100000") 
    If Not Intersect(Target, Recipient) Is Nothing Then 
     For Each c In Target 
      Set RecipientLst = Worksheets("DROP DOWN MENUS").Range("D2:D1000").Find(c.Value, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) 
      If RecipientLst Is Nothing And c <> "" Then 
       MsgBox "The value at " & c.Address(False, False) & " must be a valid " & Worksheets("DROP DOWN MENUS").Range("D1"), vbOKOnly + vbCritical 
       c.ClearContents 
      End If 
     Next 
    End If 
End Sub 

おかげ マット

Answer 1

Siのあなたの検証コードは2つのチェックの間でほとんど同じです。私はそれを別のサブに入れ、イベントハンドラから呼び出します。

Private Sub Worksheet_Change(ByVal Target As Range) 

    Dim ShtDDM As Worksheet 

    Set ShtDDM = Worksheets("DROP DOWN MENUS") 

    'in a worksheet module you can use "Me" to refer to the worksheet 
    ValidateValues Application.Intersect(Me.Range("A18:A100000"), Target), _ 
        ShtDDM.Range("C2:C1000"), _ 
        ShtDDM.Range("C1") 

    ValidateValues Application.Intersect(Me.Range("E18:E100000"), Target), _ 
        ShtDDM.Range("D2:D1000"), _ 
        ShtDDM.Range("D1") 

End Sub 

Sub ValidateValues(rngInput As Range, rngLookup As Range, sType As String) 
    Dim c As Range, f As Range, isect As Range 
    If Not rngInput Is Nothing Then 
     For Each c In rngInput.Cells 
      If Len(c.Value) > 0 Then 
       Set f = rngLookup.Find(c.Value, lookat:=xlWhole, LookIn:=xlValues, _ 
                    MatchCase:=False) 
       If f Is Nothing Then 
        Application.EnableEvents = False 
        MsgBox "The value at " & c.Address(False, False) & _ 
          " must be a valid " & sType, vbOKOnly + vbCritical 
        c.ClearContents 
        Application.EnableEvents = True 
       End If 
      End If  'has a value 
     Next c 
    End If    'any intersect? 
End Sub