excel - WorksheetFunction.countif 标准不起作用

Question

我正在使用以下代码创建唯一电子邮件的电子邮件列表。该列表有很多重复项，但我只想要一次。有些行没有分配电子邮件，所以它们显示为 我想忽略这些。

我已经在另一个工作良好的工作表中使用了它，不同之处在于在这个新应用程序上我需要将数据复制到一个临时位置，因为它已被过滤并且 CountIf不适用于过滤的行。

该代码忽略了 的条件。我想弄清楚，为什么会这样。

我首先使用 CountIf获取信贷员电子邮件列表(M​​LO 列表)。这很好用，但是获取处理器列表的代码无法正常工作。处理器列表下面的代码应该忽略任何等于 的值，但它不会:

Sheets(2).Cells.ClearContents
  lastSrcRw = Sheets("Pipeline").Cells(Rows.Count, 2).End(xlUp).Row
     For Each cell In Sheets("Pipeline").Range("E11:E" & lastSrcRw).SpecialCells(xlCellTypeVisible)
        dstRw = dstRw + 1
        cell.Copy Sheets(2).Range("A" & dstRw)
     Next

'Loop through Sheet2 list, extract unique addresses
  lastTmpRw = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
     For tmpRw = 1 To lastTmpRw
         If WorksheetFunction.CountIf(Sheets(2).Range("A1:A" & tmpRw), _
            Sheets(2).Range("A" & tmpRw)) < 2 Then
               addylist_tmp = addylist_tmp & Sheets(2).Range("A" & tmpRw).Value & "; "
         End If
     Next tmpRw

'Clean up temp addylist
     addylist = Left(addylist_tmp, Len(addylist_tmp) - 2)
     'MsgBox addylist

'Processor List
Sheets(2).Cells.ClearContents
  lastSrcRw = Sheets("Pipeline").Cells(Rows.Count, 4).End(xlUp).Row
     For Each cell In Sheets("Pipeline").Range("C11:C" & lastSrcRw).SpecialCells(xlCellTypeVisible)
        dstRw = dstRw + 1
        cell.Copy Sheets(2).Range("D" & dstRw)
     Next

'Loop through Sheet2 list, extract unique addresses
  lastTmpRw = Sheets(2).Cells(Rows.Count, 4).End(xlUp).Row
     For tmpRw = 1 To lastTmpRw
         If WorksheetFunction.CountIf(Sheets(2).Range("D1:D" & tmpRw), "<>" & "<UNASSIGNED>") Then
         If WorksheetFunction.CountIf(Sheets(2).Range("D1:D" & tmpRw), Sheets(2).Range("D" & tmpRw)) < 2 Then
                addylist_tmp2 = addylist_tmp2 & Sheets(2).Range("D" & tmpRw).Value & "; "
         End If
         End If
     Next tmpRw

'Clean up temp addylist
     addylist2 = Left(addylist_tmp2, Len(addylist_tmp2) - 2)

Answer 1

您已经知道如何确定包含电子邮件地址的单元格范围。我的解决方案以此为基础创建一个 Dictionary唯一的电子邮件地址，并且作为额外的奖励对您“认为”是电子邮件地址的文本字符串的格式进行一些快速验证。

首先，为了验证文本字符串以检查电子邮件地址格式，我创建了一个函数，它首先查找 @字符，然后确保分隔符右侧的文本部分至少有一个点。

Private Function IsValidEmailFormat(ByVal thisText As String) As Boolean
    IsValidEmailFormat = False
    Dim tokens() As String
    tokens = Split(thisText, "@")
    If UBound(tokens) = 1 Then
        '--- we found the domain separator, do we have a dot?
        tokens = Split(tokens(1), ".")
        If UBound(tokens) >= 1 Then
            '--- we found the dot, looks like an email address
            IsValidEmailFormat = True
        End If
    End If
End Function

接下来，我们将使用该函数来构建我们的 Dictionary。从给定的范围。你会看到在这个函数中，我们将给定的范围复制到一个基于内存的数组中(阅读更多关于它的信息 here)。之后，确保我们有一个有效的电子邮件格式的字符串，检查它是否已经在字典中——这就是我们可以保证我们有一个唯一电子邮件地址列表的方法。

Private Function GetUniqueEmails(ByRef thisRange As Range) As Dictionary
    Dim theseEmails As Dictionary
    Set theseEmails = New Dictionary

    '--- copy to memory array
    Dim thisData As Variant
    thisData = thisRange

    Dim i As Long
    For i = LBound(thisData, 1) To UBound(thisData, 1)
        If IsValidEmailFormat(thisData(i, 1)) Then
            If Not theseEmails.Exists(thisData(i, 1)) Then
                theseEmails.Add thisData(i, 1), i
            End If
        End If
    Next i
    Set GetUniqueEmails = theseEmails
End Function

最后，正如从主代码逻辑调用的那样，您可以对结果列表执行您想要的操作。我形成了一个与您的示例类似的分号分隔列表。

这是单个 block 中的整个示例代码:

Option Explicit

Sub TestMe()
    Dim emails As Dictionary
    Set emails = GetUniqueEmails(Sheet3.Range("A1:A5"))

    '--- convert the emails to a semi-colon separated list for later use
    Debug.Print "there are " & emails.Count & " emails in the list"
    Dim emailList As String
    Dim email As Variant
    For Each email In emails.Keys
        emailList = emailList & email & ";"
    Next email
    emailList = Left(emailList, Len(emailList) - 1) 'remove the trailing ";"
End Sub

Private Function GetUniqueEmails(ByRef thisRange As Range) As Dictionary
    Dim theseEmails As Dictionary
    Set theseEmails = New Dictionary

    '--- copy to memory array
    Dim thisData As Variant
    thisData = thisRange

    Dim i As Long
    For i = LBound(thisData, 1) To UBound(thisData, 1)
        If IsValidEmailFormat(thisData(i, 1)) Then
            If Not theseEmails.Exists(thisData(i, 1)) Then
                theseEmails.Add thisData(i, 1), i
            End If
        End If
    Next i
    Set GetUniqueEmails = theseEmails
End Function

Private Function IsValidEmailFormat(ByVal thisText As String) As Boolean
    IsValidEmailFormat = False
    Dim tokens() As String
    tokens = Split(thisText, "@")
    If UBound(tokens) = 1 Then
        '--- we found the domain separator, do we have a dot?
        tokens = Split(tokens(1), ".")
        If UBound(tokens) >= 1 Then
            '--- we found the dot, looks like an email address
            IsValidEmailFormat = True
        End If
    End If
End Function