Question

VBA新手在这里。我确实找到了一些关于编码这些循环的信息，但是我很难确定它是否适用于我的特定需求和/或它如何适用于我的特定需求，所以提前感谢您提供任何帮助。

为了在格式化和上传之前的QA信息，我想循环遍历多组动态范围，并检查该范围内另一列的信息。每个范围都按D列中的电子邮件地址分组，我需要确保G列中也列出了相同的电子邮件（我将在上传之前删除B-D列）。由于每个分组可以是1到100行，我已经编码了如何定义范围（下面），但是如何添加一个循环来单独执行每个组中的检查？

所有这些的输出应该是一个消息框，或者说“全部清除！”如果代码没有发现错误，或者“[名称]未列出。请在继续之前添加他们的信息。”如果他们没有列出。

我假设我应该为此做一些Do While或Do Until或For循环，但后来我在概念上混淆了是否在循环中或循环外声明我的变量然后如何连接可能多个未列出的在最后的同一个消息框中输入名称。

这是我到目前为止所拥有的：

Sub QANameIsListed()
'Declare the variables.
Dim nRow As Long
Dim nStart As Long, nEnd As Long
Dim sEmail As String
Dim sName As String

'Figure out what first email address is.
sEmail = Range("D2").Text

'Figure out where first group data starts.
For nRow = 1 To 65536
    If Range("D" & nRow).Value = sEmail Then
        nStart = nRow
    End If
Exit For
Next nRow

'Figure out where first group data ends.
For nRow = nStart To 65536
    If Range("D" & nRow).Value <> sEmail Then
        nEnd = nRow
    End If
Exit For
Next nRow
nEnd = nEnd - 1

'Check whether the name is listed in the second column.
With Range("G" & nStart & ":G" & nEnd)
sName = Range("B" & nStart).Text & " " & Range("C" & nStart).Text
    Set c = .Find(sEmail)
    If c Is Nothing Then
        MsgBox (sName & " " & "isn't listed." _
        & "  " & "Please add their information before continuing.")
    Else
        MsgBox ("All clear!")
    End If
End With
End Sub

Answer 1

我的帖子中没有真正的问题。 :)但是，这是我的看法。

首先，您将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位置的测试结果：

Similar set-up.

大规模编辑：

根据与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

结果的Screencap：

Should be perfect now.

最后编辑（HOPEFULLY）：

以下代码考虑到事先没有列表。这将在列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

多个组的结果相同，只有一个组存在时不会出错。

如果有帮助，请告诉我。

如何在顺序动态范围内执行功能？

1 个答案: