Excel 将公式放入范围的更快方法

我有一个宏来设置范围的公式。它在小范围内工作，但如果范围超过1000，则执行速度非常慢

另外，

Application.screenUpdate=False

不起作用

以下是设置： 我有一个列，在那里我粘贴电子邮件或密码。 然后单击按钮运行宏，检查电子邮件或密码是否有效，并仅对有值的行返回True或False

这是我的密码：

Sub ValEmail()

Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False

Dim lastRow As String
Dim useRange As String
Dim cel As Range
Dim validEmail As Range
Dim rnum As Integer

'Gets the Last Row Used
rnum = Range("A" & Rows.Count).End(xlUp).Row

lastRow = "F" & rnum

'Set the Range where formula will be put
useRange = "F2" & ":" & lastRow

Set validEmail = Range(useRange)

'Put formula into Range
validEmail.Formula = "=IsEmailValid(A2)"

Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub

我的代码可以工作，但速度非常慢，尤其是当我有10k+行的值时。即使只有200行，速度也很慢

编辑，以下是我的有效代码：

Function IsEmailValid(strEmail)

Dim strArray As Variant
Dim strItem As Variant
Dim i As Long, c As String, blnIsItValid As Boolean
blnIsItValid = True

i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))
If i <> 1 Then IsEmailValid = False: Exit Function
ReDim strArray(1 To 2)
strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)
strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")
For Each strItem In strArray
    If Len(strItem) <= 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    For i = 1 To Len(strItem)
        c = LCase(Mid(strItem, i, 1))
        If InStr("abcdefghijklmnopqrstuvwxyz'_-.", c) <= 0 And Not IsNumeric(c) Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
    Next i
    If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
Next strItem
If InStr(strArray(2), ".") <= 0 Then
    blnIsItValid = False
    IsEmailValid = blnIsItValid
    Exit Function
End If
i = Len(strArray(2)) - InStrRev(strArray(2), ".")
If i <> 2 And i <> 3 Then
    blnIsItValid = False
    IsEmailValid = blnIsItValid
    Exit Function
End If
If InStr(strEmail, "..") > 0 Then
    blnIsItValid = False
    IsEmailValid = blnIsItValid
    Exit Function
End If
IsEmailValid = blnIsItValid

End Function

函数IsEmailValid（strEmail）
作为变体的dimstrarray
作为变体的暗条纹
Dim i为长，c为字符串，blnIsItValid为布尔值
blnIsItValid=True
i=Len（strEmail）-Len（Application.Substitute（strEmail，@，“”）
如果i为1，则IsEmailValid=False:Exit函数
雷迪姆街（1至2）
strArray（1）=左（strEmail，InStr（1，strEmail，“@”，1）-1）
strArray（2）=申请。替换（右（strEmail，Len（strEmail）-Len（strArray（1）），“@”，和“）
对于strArray中的每一个跨步
如果Len（strItem）像这样的东西不管用吗？我试着做一个简短的版本

Sub valEmail()

    Dim rnum As Long

    Application.ScreenUpdating = False    

    With ActiveSheet

    rnum = Range("A" & Rows.Count).End(xlUp).Row
    Range("F2").Formula = "=isemailvalid(A2)"
    Range("F2").Copy Destination:=Range("F3" & ":" & "F" & rnum)

    End with

    Application.ScreenUpdating = True

End Sub

请尝试此功能
IsEmailValid
而不是您的：

Public Function IsEmailValid(ByVal EmailAddress As String) As Boolean
    Dim RegEx As Object
    Set RegEx = CreateObject("vbscript.regexp")

    With RegEx
        .IgnoreCase = True
        .Global = True
        .Pattern = "^((\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*)\s*[;]{0,1}\s*)+$"
    End With

    IsEmailValid = RegEx.test(EmailAddress)
End Function

可在此处找到电子邮件的替代正则表达式：


Public Sub-ValEmail（）
Application.Calculation=xlCalculationManual
Application.DisplayStatusBar=False
Application.EnableEvents=False
ActiveSheet.DisplayPageBreaks=False
Application.ScreenUpdating=False
关于错误转到捕获
最后一排一样长
LastRow=范围（“A”和Rows.Count）.End（xlUp）.Row
变暗有效数字音频范围
设置validEmail=范围（“F2”、“F”和最后一行）
validEmail.Formula=“=IsEmailValid（A2）”
错误转到0
捕获：
Application.Calculation=xlCalculationAutomatic
Application.DisplayStatusBar=True
Application.EnableEvents=True
ActiveSheet.DisplayPageBreaks=True
Application.ScreenUpdating=True
如果错误号为0，则
Err.Raise Err.Number、Err.Source、Err.Description、Err.HelpFile、Err.HelpContext
呃，明白了
如果结束
端接头
您能否为IsEmailValid提供代码。因为这可能会花费很多时间。实际上这应该是最快的方法。虽然代码可以缩短一点，但这并不能显著提高速度。正如omaril已经说过的，您的
IsEmailValid
函数似乎占用了大量时间。问题不在于您发布的代码，而在于
IsEmailValid
的代码。如果
IsEmailValid
仅需1秒即可分析1个单元格，则1000个单元格的分析时间已为1000秒。这就是问题所在。您的问题并添加
IsEmailValid
的代码。我已经编辑了我的问题并添加了IsEmailValid函数。虽然它只需要几分之一秒就可以执行，如果在手机上使用的话。这比我以前的代码运行得更快。虽然我将“validEmail.Formula=“=IsEmailValid（A2）”替换为函数。
Public Sub ValEmail()
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.ScreenUpdating = False

    On Error GoTo CATCH
    Dim LastRow As Long
    LastRow = Range("A" & Rows.Count).End(xlUp).Row

    Dim validEmail As Range
    Set validEmail = Range("F2", "F" & LastRow)

    validEmail.Formula = "=IsEmailValid(A2)"

    On Error Goto 0

CATCH:
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.ScreenUpdating = True

    If Err.Number <> 0 Then
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
        Err.Clear
    End If
End Sub