我在你的帖子中没有看到真正的问题。:) 但是，这是我的看法。
首先，你把你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
多组结果相同，只有一组时不会出错。
让我知道这是否有帮助。