Excel/VBA Worksheet_Change整個重複

Question

我有一個workheet_change宏正在運行。我想要的是檢查用戶何時粘貼來自其他工作簿的符合特定條件的值。例如，如果最終用戶粘貼到列A（起始於A18）（即標題列），則其值將被拒絕，除非它們在標題列C下的另一個工作表「下拉菜單」上符合值。等等在整個工作表中需要匹配幾行。

現在發生的情況是，如果我在列A-E中發佈值，並且A18中的值不是有效的標題，則會出現消息框「單元格中的值必須是A18，B18的有效」標題「 C18，D18和E18，然後如果E18不是有效的類型，它會返回並告訴我A18也是無效的。我覺得這是一個application.enable = false類型的解決方案，但無法弄清楚。

由於

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

硅你的驗證代碼在兩次檢查之間幾乎是相同的，我會把它放到一個單獨的sub中，並從事件處理程序調用它。

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