Question

我有一个宏，用于设置范围的公式。它适用于小范围，但如果范围超过1000，则执行速度非常慢

Application.ScreenUpdating = False也不起作用

这是设置：我在A列中粘贴了电子邮件或密码。然后，我单击一个按钮以运行宏，以检查电子邮件或密码是否有效，并仅对具有值的行返回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行，也非常慢。

编辑，这是我的IsEmailValid代码：

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

Answer 1

尝试使用此功能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

电子邮件的替代正则表达式可以在这里找到：https://emailregex.com

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

Answer 2

像这样的作品难道不是吗？我试图做一个简短的版本。

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

Answer 3

也许可以尝试一下：

Sub valEmail()
    Range("F2:F"& Range("A2").CurrentRegion.Rows.Count).Formula = "=isemailvalid(A2)"
End Sub

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

3 个答案: