Question

我正在使用以下代码创建唯一电子邮件的电子邮件列表。列表中有很多重复项，但我只想要一次。某些行尚未分配电子邮件，因此显示为，我想忽略这些行。

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

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

我首先使用CountIf来获得信贷员的电子邮件列表（MLO列表）。效果很好，但是获取“处理器”列表的代码无法正常工作。处理器列表下面的代码应该忽略任何等于的值，但不会：

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

重置行计数器，然后在其他列上重新使用它。

您需要在dstRw = 0上方的一行中插入'Processor List

喜欢这个...

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

dstRw = 0

'Processor List
Sheets(2).Cells.ClearContents

我认为您可能会对Sheet(2)上的内容和结果的真实性感到困惑。您的结果存储在addylist2

中

这是我用来测试的完整运行代码。因为我没有您的数据，因此仅对您进行了少量修改。

addylist2中的结果为123，所有过滤和排除的条件都将被忽略。

Sub aaa()

Dim cell As Range
Dim lastTmpRw As Long
Dim addylist_tmp As String
Dim addylist_tmp2 As String
Dim tmpRw As Long
Dim dstRw As Long
Dim lastSrcRw As Long
Dim addylist As String
Dim addylist2 As String

Sheets(2).Cells.ClearContents
  lastSrcRw = Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
     For Each cell In Sheets(1).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

dstRw = 0

'Processor List
Sheets(2).Cells.ClearContents
  lastSrcRw = Sheets(1).Cells(Rows.Count, 4).End(xlUp).Row
     For Each cell In Sheets(1).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)
Sheet3.Cells.Clear
Sheet3.Cells(1, 1) = addylist
Sheet3.Cells(2, 1) = addylist2

End Sub

Answer 2

您已经知道如何确定保存电子邮件地址的单元格范围。我的解决方案基于此，创建了一个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）。此后，确保我们有一个有效的电子邮件格式的字符串，请检查它是否已存在于字典中-这是我们可以保证我们拥有UNIQUE电子邮件地址列表的方法。

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

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

下面是整个示例代码：

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

Answer 3

我能够在MrExcel论坛中从一个名为Fluff的用户那里找到一个简单的解决方案：

Sub mecerrato()
Dim Cl As Range
Dim Mlst As String, Plst As String
Dim Mdic As Object, Pdic As Object

Set Mdic = CreateObject("scripting.dictionary")
Set Pdic = CreateObject("scripting.dictionary")
With Sheets("Pipeline")
  For Each Cl In .Range("C11", .Range("C" & 
Rows.Count).End(xlUp)).SpecialCells(xlVisible)
     If Cl.Value <> "" And Cl.Value <> "<UNASSIGNED>" Then Pdic(Cl.Value) = Empty
     If Cl.Offset(, 2).Value <> "" Then Mdic(Cl.Offset(, 2).Value) = Empty
  Next Cl
End With
Mlst = Join(Mdic.Keys, "; ")
Plst = Join(Pdic.Keys, "; ")
End Sub

WorksheetFunction.countif条件不起作用

3 个答案: