数据验证应用于任何突出显示的列，该列允许具有特定文本的值

Question

我需要的代码

1.(在标题中查找字符串(在本例中，让我们说"电子邮件"(

2.(突出显示包含标题名称的整列

3.(应用数据验证，该数据验证将只允许具有"0"的值@">

我有ff代码。它高亮显示该列并运行验证，但我得到了不正确的输出。即使在输入带有"@">

Sub FindAddressColumn()
Dim xRg As Range
Dim xRgUni As Range
Dim xFirstAddress As String
Dim xStr As String
On Error Resume Next
xStr = "Email"
Set xRg = Range("A1:BZ1").Find(xStr, , xlValues, xlWhole, , , True)
If Not xRg Is Nothing Then
xFirstAddress = xRg.Address
Do
Set xRg = Range("A1:BZ1").FindNext(xRg)
If xRgUni Is Nothing Then
Set xRgUni = xRg
Else
Set xRgUni = Application.Union(xRgUni, xRg)
End If
Loop While (Not xRg Is Nothing) And (xRg.Address <> xFirstAddress)
End If
xRgUni.EntireColumn.Select
With Selection.Validation
.Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertWarning, Operator _
:=xlBetween, Formula1:="=ISNUMBER(FIND(""@"",))"
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Invalid Email"
.ShowInput = True
.ShowError = True
End With
Range("A1").Select
End Sub

我在想，这是否与验证公式有关。提前感谢！

Answer 1

我不认为可以合并所有列并应用基于公式的验证：更容易单独处理每一列。

此外，find/findnext逻辑可以更好地分解为可重用函数。

Sub SetUpEmailValidation()

Dim allHdrs As Collection, c As Range, rng As Range

Set allHdrs = FindAll(Range("A1:BZ1"), "Email")
For Each c In allHdrs
Set rng = c.Offset(1, 0).Resize(Rows.Count - c.Row)
With rng.Validation
.Delete
.Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, _
Formula1:="=ISNUMBER(FIND(""@""," & rng.Cells(1).Address(False, False) & "))"
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Invalid Email"
.ShowInput = True
.ShowError = True
End With
Next c
End Sub
'find all cells with matching values in a range
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function