突出显示不符合下拉条件的单元格

Question

我有一个包含下拉选项的电子表格，但人们一直在复制和粘贴不适合下拉选项的条目。

我创建了一个 VBA 来扫描工作表，并且在单元格中出现一条错误消息，其中的条目不适合下拉选项。我只需要它以黄色突出显示需要更改的单元格，以便轻松找到它们。有人可以帮忙吗？

这是我现在的 VBA:

Sub TestValidation()
 
Dim myRng As Range
Dim ErrorMsg As String
Dim NoErrorMsg As String
Dim FoundCells As String
Dim cell As Range
 
Set myRng = Sheets("Portfolio Tracker").Range("D3:AK5000")
ErrorMsg = "You've entered something in a drop-down box cell that isn't a drop-down box option. Please change"
NoErrorMsg = "No cells that do not abide to validation"
FoundCells = ""
For Each cell In myRng
   If Not cell.Validation.Value Then
      FoundCells = FoundCells & "," & cell.Address
   End If
   Next cell
If Len(FoundCells) >= 1 Then
   MsgBox ErrorMsg & Right(FoundCells, Len(FoundCells) - 1)
Else
   MsgBox NoErrorMsg
End If
Set myRng = Nothing
 
End Sub

Answer 1

您可以使用 Worksheet_Change 事件，如果有人粘贴了无效值，它将撤消粘贴并抛出一条消息。

请注意，除此过程外，您还需要使用 DataValidation。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RevertChanges As Boolean
    
    Const WatchedRange As String = "D3:AK5000"
    
    On Error GoTo ENABLE_EVENTS  ' in case of error enable events
    Application.EnableEvents = False
    
    
    Dim AffectedCells As Range
    Set AffectedCells = Intersect(Target, Me.Range(WatchedRange))
    
    If Not AffectedCells Is Nothing Then
        Dim ValidationType As Variant
        ValidationType = AffectedCells(1).Validation.Type
        
        If Not IsEmpty(ValidationType) Then
            Dim Cell As Range
            For Each Cell In AffectedCells
                If Cell.Value <> "" Then
                    If Not Cell.Validation.Value Then
                        RevertChanges = True
                        Exit For
                    End If
                End If
            Next Cell
        Else
            RevertChanges = True
        End If
        
        If RevertChanges Then
            MsgBox "Invalid values were pasted. Undo pasting.", vbCritical, "Computer Says No"
            Application.Undo
        End If
    End If
    
ENABLE_EVENTS:
    Application.EnableEvents = True
End Sub

或者只对下拉菜单使用数据验证，然后使用 Sheets("Portfolio Tracker").CircleInvalid 圈出无效值：

Answer 2

如果您只想为无效单元格着色，您可以在第一个 if 条件中添加 cell.Interior.Color = 65535。

   If Not cell.Validation.Value Then
        cell.Interior.Color = 65535
        FoundCells = FoundCells & "," & cell.Address
   End If

突出显示不符合下拉条件的单元格

Highlight cells that don’t meet the drop down criteria

validation

excel

vba

copy-paste

dropdown