Excel VBA，使用if语句和坏电子邮件列表清理数据

我想使用VBA中的if语句来帮助我清理CSV文件我有一个“坏”电子邮件列表，并希望将它们添加到语句中，以便程序运行时能够拾取电子邮件x、y和z

我发现一个youtube视频解释了如何删除带有空值或0值的行，但还没有确定是否可以扩展它

Sub CleanData()

' Disable certain Excel Features, whilst the macro is running
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = False
Application.ScreenUpdating = False

    ' Decalare Variables
    Dim DeleteRow As Long
    Dim ws As Worksheet

    ' Set objects
    Set ws = ActiveSheet

        ' Loop through the rows of data, in order to delete rows with a
        ' zero value in column O. Our data commences of row 5
        For DeleteRow = ws.Range("O" & Rows.Count).End(xlUp).Row To 2 Step -1

            ' Identify values in col O, which are zero & delete entire row
            If ws.Range("O" & DeleteRow).Value = 0 Then
            Rows(DeleteRow).EntireRow.Delete
            End If

        'Move to next cell in the range, whitch is being looped
        Next DeleteRow

    ' Re-enable the above Excel Features, Whitch were disabled whilst the macro ran
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

在下面的部分中，我想添加其他“坏的/不想要的”电子邮件

---

非常感谢您的阅读或帮助，为我指明正确的方向。

看看这是否适合您

Option Explicit

Sub CleanData()

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim ws As Worksheet, delCollection As Range, ckRng As Range, cel As Range
    Dim TestArr(4)  '< Set this to number of strings you have starting at 0

    'Create your array of search values to delete
    TestArr(0) = 0
    TestArr(1) = ""
    TestArr(2) = "a String"
    TestArr(3) = "a String with wildcard*"
    TestArr(4) = "*String with multiple wildcards*"

    Set ws = ThisWorkbook.ActiveSheet
    Set ckRng = ws.UsedRange.Columns("O")

    For Each cel In ckRng.Cells
        If OrLikeArr(cel.Value, TestArr) Then
            If delCollection Is Nothing Then
                Set delCollection = cel.EntireRow
            Else
                Set delCollection = Application.Union(cel, delCollection)
            End If
        End If
    Next cel

    If Not delCollection Is Nothing Then delCollection.EntireRow.Delete

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

实现目标的方法有很多，但在我建议的方法中，您将所有符合条件的行（在本例中为

=0

）添加到范围

delCollection

）。您可以使用

Union

方法执行此操作

找到所有符合条件的项目并将其添加到此范围后，您将在一次点击中删除该范围，而不是逐行删除。这样做可以提高性能

编辑 我刚刚意识到您在代码的开头和结尾都将calculation设置为

xlCalculationAutomatic

。更新了我的代码以更正此问题

编辑#2 我在答案中添加了函数

orlikerar

。您可以使用此选项，而不是像x一样键入

cel.Value或像y一样键入cel.Value或像z一样键入cel.Value

。此函数使代码更加清晰

但是说到这里，我还对原始代码进行了修改。我添加了一个数组，您需要在该数组中输入自定义值。您声明的一个值是

0

，您可以看到我添加为

TestArr（0）=0

---

将所有值添加到此数组后，请确保

TestArr（i）

上的声明正确无误

i

需要是测试字符串的总数-正如您所看到的，我用

TestArr（4）

停止了，所以它说

Dim TestArr（4）

感谢您的响应，我尝试运行它，但没有做任何更改，原始代码中的“0”只会删除“o”行中的空白单元格，不确定我将在哪里添加额外的“坏”实体，即。na@na.com或no@email.comUpdated代码。您可以添加所有要搜索的值，无论是

0

，还是

na@na.com

等。您需要将它们添加到数组

TestArr（）

。

Option Explicit

Sub CleanData()

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim ws As Worksheet, delCollection As Range, ckRng As Range, cel As Range
    Dim TestArr(4)  '< Set this to number of strings you have starting at 0

    'Create your array of search values to delete
    TestArr(0) = 0
    TestArr(1) = ""
    TestArr(2) = "a String"
    TestArr(3) = "a String with wildcard*"
    TestArr(4) = "*String with multiple wildcards*"

    Set ws = ThisWorkbook.ActiveSheet
    Set ckRng = ws.UsedRange.Columns("O")

    For Each cel In ckRng.Cells
        If OrLikeArr(cel.Value, TestArr) Then
            If delCollection Is Nothing Then
                Set delCollection = cel.EntireRow
            Else
                Set delCollection = Application.Union(cel, delCollection)
            End If
        End If
    Next cel

    If Not delCollection Is Nothing Then delCollection.EntireRow.Delete

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Function OrLikeArr(ByVal compareStr As String, _
    ParamArray compareArr() As Variant) As Boolean

    Dim i As Long, TestArr
    OrLikeArr = False
    TestArr = compareArr(0)

    For i = LBound(TestArr) To UBound(TestArr)
        Debug.Print "Testing [" & compareStr & "] to [" & TestArr(i) & "] ";
        If compareStr Like TestArr(i) Then
            OrLikeArr = True
            Debug.Print OrLikeArr
            Exit Function
        End If
        Debug.Print OrLikeArr
    Next i

End Function