我有一個帶有下拉選項的電子表格，人們不斷復制和粘貼不適合下拉選項的條目。
我創建了一個掃描作業表的 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
uj5u.com熱心網友回復：
您可以使用該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圈出無效值：
uj5u.com熱心網友回復：
如果您只想為無效單元格著色，您可以cell.Interior.Color = 65535在第一個 if 條件中添加。
If Not cell.Validation.Value Then
cell.Interior.Color = 65535
FoundCells = FoundCells & "," & cell.Address
End If
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/440556.html