我在您的帖子中没有看到任何真正的问题。 :) 但是，这是我的看法。
首先，您将Exit For 放置在错误的位置。如果将其放在If---End If 块之外，那么您的For 循环将始终在到达Next nRow 之前退出。
其次，您循环通过 65536 个单元两次，这不仅是资源密集型的，而且也不完全兼容。如果我的数据在第 65537 行，我会完全避开循环。毕竟，在 Excel 2007 及以后的版本中，有一百万行可用。
我的建议是，只使用Find。我们将使用它从顶部查找sEmail 的第一次出现和底部的sEmail 的最后一次出现。我们将为此返回他们的行索引。当然，这仅适用于您的电子邮件已正确排序的假设...
最后的部分很简单，但是可以逃过一些初学者，所以不用担心。我们所做的是，我们声明从上面确定的范围，我们将在这个范围内循环。你就快到了，太好了。
我对您的代码的修改未经测试，但它捕获了您尝试实现的目标，然后可能还有一些。有些行我冒昧地完全删除，因为我发现它们是不必要的（Set c = .Find(sEmail)，其中之一）。我还添加了一些其他“对新手友好”的东西，比如Boolean 检查和MsgBox 中多行的快速而肮脏的方法。
代码如下：
Sub QANameIsListed()
'Declare the variables.
Dim nRow As Long
Dim nStart As Long, nEnd As Long
Dim sEmail As String
Dim sName As String
Dim cRng As Range, cL As Range 'BK201: Declare cRng.
Dim rStr As String 'BK201: For multiple unlisted names.
Dim aClr As Boolean 'BK201: To check if it's all clear.
'Figure out what the first email address is.
sEmail = Range("D2").Value
'Figure out where first group data starts.
nStart = Range("D:D").Find(sEmail).Row
'Figure out where first group data ends.
nEnd = Range("D:D").Rows.Find(What:=sEmail, SearchDirection:=xlPrevious).Row
'BK201: Set the target range.
Set cRng = Range("G" & nStart & ":G" & nEnd)
'BK201: Set a default value for aClr.
aClr = True
For Each cL In cRng
'Similar to B and C.
sName = cL.Offset(0, -5).Value & " " & cL.Offset(0, -4).Value
If cL.Value = sEmail Then
'Do nothing. Let the loop continue.
Else
aClr = False 'BK201: Oops. At least one entry isn't listed.
rStr = rStr & sName & vbNewLine
End If
Next cL
If aClr Then 'BK201: If all is clear...
MsgBox "All clear!"
Else 'BK201: Otherwise...
rStr = "The unlisted names are:" & vbNewLine & vbNewLine & rStr
rStr = rStr & vbNewLine & vbNewLine & "Please add their information before continuing."
MsgBox rStr
End If
End Sub
不过，这并没有到此结束，因为这只会对您列表中的一封电子邮件正常运行，并且该电子邮件也位于D2，这是nStart 无论如何都会默认的位置。因此，即使使用上面的代码，我的下一个建议是：最好在其他地方列出所有唯一电子邮件，然后对其进行迭代，sEmail 等于当前迭代的电子邮件字符串。
如果这听起来不错，请告诉我们，以便我们可以相应地应用它。否则，此代码将在您当前的设置或请求中正常工作。 :)
sEmail 的测试结果位于下面的M2 而不是D2：
大规模编辑：
根据与 OP 的交流，以下内容应该可以解决问题。但是请注意，为了方便起见，我冒昧地假设所有团队负责人的唯一电子邮件列表都位于某个地方。根据需要修改代码。代码如下：
Private Sub CheckIfLeadExists()
'Dimension area.
Dim wSht As Worksheet
Dim rMem As Range
Dim vList As Variant, vElement As Variant
Dim lStart As Long, lEnd As Long
Dim sEmail As String, sName As String, rStr As String
Dim bClear As Boolean
'Assignment area.
Set wSht = ThisWorkbook.Sheets("Sheet1") 'Modify as necessary.
vList = wSht.Range("J2:J4").Value 'Assign the unique e-mails to a variable.
bClear = True 'Default value of boolean check for clear run.
For Each vElement In vList 'Iterate over the e-mails.
sEmail = vElement
With wSht
'Find the starting row for current e-mail of loop.
lStart = .Columns("D").Find(sEmail).Row
'Likewise, find the ending row for current e-mail of loop.
lEnd = .Columns("D").Find(sEmail, SearchDirection:=xlPrevious).Row
'Get the lead's name.
sName = .Cells(lStart, 2).Value & " " & .Cells(lStart, 3).Value
'Assign the member's area to a range.
Set rMem = .Range("E" & lStart & ":G" & lEnd)
End With
'We now search this member's area for the current lead's e-mail.
If Not rMem.Find(sEmail) Is Nothing Then
'E-mail exists in member's area. Do nothing.
Else
bClear = False 'Oops. At least one entry isn't listed.
rStr = rStr & sName & vbNewLine 'Add to string.
End If
Next vElement
If bClear Then 'If all is clear...
MsgBox "All clear!"
Else 'Otherwise, list them all.
rStr = "The unlisted names are:" & vbNewLine & vbNewLine & rStr
rStr = rStr & vbNewLine & "Please add their information before continuing."
MsgBox rStr
End If
End Sub
结果截图：
最后编辑（希望如此）：
以下代码考虑到事先没有列表。这将在 J 列中创建列表。
Private Sub CheckIfLeadExists()
'Dimension area.
Dim wSht As Worksheet
Dim rMem As Range
Dim vList As Variant, vElement As Variant
Dim lStart As Long, lEnd As Long, lRow As Long
Dim sEmail As String, sName As String, rStr As String
Dim bClear As Boolean
Dim oDict As Object, vMails As Variant, vItem As Variant
Dim lCount As Long
'Assignment area.
Set wSht = ThisWorkbook.Sheets("Sheet1") 'Modify as necessary.
'Get first all the emails with duplicates. Modify as necessary.
vMails = wSht.Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row).Value
'Create a dictionary.
Set oDict = CreateObject("Scripting.Dictionary")
With oDict
For Each vItem In vMails
If Not .Exists(vItem) And Not IsEmpty(vItem) Then
.Add vItem, Empty
End If
Next vItem
End With
'Copy unique list of e-mails to column J.
lRow = oDict.Count
wSht.Range("J2").Resize(lRow, 1).Value = Application.Transpose(oDict.Keys)
vList = wSht.Range("J2:J" & lRow + 1).Value 'Assign the unique e-mails to a variable.
bClear = True 'Default value of boolean check for clear run.
For Each vElement In vList 'Iterate over the e-mails.
sEmail = vElement
With wSht
'Find the starting row for current e-mail of loop.
lStart = .Columns("D").Find(sEmail).Row
'Likewise, find the ending row for current e-mail of loop.
lEnd = .Columns("D").Find(sEmail, SearchDirection:=xlPrevious).Row
'Get the lead's name.
sName = .Cells(lStart, 2).Value & " " & .Cells(lStart, 3).Value
'Assign the member's area to a range.
Set rMem = .Range("E" & lStart & ":G" & lEnd)
End With
'We now search this member's area for the current lead's e-mail.
If Not rMem.Find(sEmail) Is Nothing Then
'E-mail exists in member's area. Do nothing.
Else
bClear = False 'Oops. At least one entry isn't listed.
rStr = rStr & sName & vbNewLine 'Add to string.
End If
Next vElement
If bClear Then 'If all is clear...
MsgBox "All clear!"
Else 'Otherwise, list them all.
rStr = "The unlisted names are:" & vbNewLine & vbNewLine & rStr
rStr = rStr & vbNewLine & "Please add their information before continuing."
MsgBox rStr
End If
End Sub
结果是一样的。希望这会有所帮助！
后续编辑：
在处理字典时，由于并非总是遇到只有一项的字典（至少根据我的经验），Transpose 通常是将键或项打印到范围的最佳方法。但是，由于字典中只有一项，因此无法将其打印出来（从不费心检查确切原因）。但是，遍历键或项目就可以了，并且应该会打印出那个唯一的键/项目。请参阅以下编辑。
Private Sub CheckIfLeadExists()
'Dimension area.
Dim wSht As Worksheet
Dim rMem As Range
Dim vList As Variant, vElement As Variant
Dim lStart As Long, lEnd As Long, lRow As Long
Dim sEmail As String, sName As String, rStr As String
Dim bClear As Boolean
Dim oDict As Object, vMails As Variant, vItem As Variant
Dim lCount As Long
'Assignment area.
Set wSht = ThisWorkbook.Sheets("Sheet5") 'Modify as necessary.
'Get first all the emails with duplicates. Modify as necessary.
vMails = wSht.Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row).Value
'Create a dictionary.
Set oDict = CreateObject("Scripting.Dictionary")
With oDict
For Each vItem In vMails
If Not .Exists(vItem) And Not IsEmpty(vItem) Then
.Add vItem, Empty
End If
Next vItem
End With
'Copy unique list of e-mails to column J.
lRow = 2 '--Changed this.
For Each Key In oDict.Keys '--Changed this as well.
wSht.Range("J" & lRow).Value = Key
lRow = lRow + 1
Next Key
vList = wSht.Range("J2:J" & lRow + 1).Value 'Assign the unique e-mails to a variable.
bClear = True 'Default value of boolean check for clear run.
For Each vElement In vList 'Iterate over the e-mails.
sEmail = vElement
With wSht
'Find the starting row for current e-mail of loop.
lStart = .Columns("D").Find(sEmail).Row
'Likewise, find the ending row for current e-mail of loop.
lEnd = .Columns("D").Find(sEmail, SearchDirection:=xlPrevious).Row
'Get the lead's name.
sName = .Cells(lStart, 2).Value & " " & .Cells(lStart, 3).Value
'Assign the member's area to a range.
Set rMem = .Range("E" & lStart & ":G" & lEnd)
End With
'We now search this member's area for the current lead's e-mail.
If Not rMem.Find(sEmail) Is Nothing Then
'E-mail exists in member's area. Do nothing.
Else
bClear = False 'Oops. At least one entry isn't listed.
rStr = rStr & sName & vbNewLine 'Add to string.
End If
Next vElement
If bClear Then 'If all is clear...
MsgBox "All clear!"
Else 'Otherwise, list them all.
rStr = "The unlisted names are:" & vbNewLine & vbNewLine & rStr
rStr = rStr & vbNewLine & "Please add their information before continuing."
MsgBox rStr
End If
End Sub
多组结果相同，只有一组时不会报错。
如果这有帮助，请告诉我。