Как выполнить функцию в последовательных динамических диапазонах?

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 ниже:

MASSIVE EDIT:

В соответствии с ОП обмен, следующий должен сделать трюк. Обратите внимание, однако, что для моего удобства я взял на себя смелость предположить, что список уникальных электронных писем всех руководителей команд находится где-то. При необходимости измените код. Код следующим образом:

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 результата:

ПОСЛЕДНИЙ EDIT (многообещающе):

После кода учитывающую не имея список заранее. Это создаст список в столбце 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 

Результаты одинаковы. Надеюсь это поможет!

FOLLOW-UP EDIT:

При работе со словарями, так как это не всегда вы сталкиваетесь словарь только один пункт (по крайней мере в моем опыте), 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 

Результаты одинаковые для нескольких групп, и он не будет выходить из системы, если присутствует только одна группа.

Дайте мне знать, если это поможет.