Редактирование макроса командной кнопки для поиска в одном столбце нескольких значений ячеек

Question

Хорошо, поэтому я постараюсь сформулировать это как можно более четко ...

Я создал электронную таблицу, в которой всего 8 листов.Первый лист - это первая страница, на которой хранятся все данные в рабочей книге, если хотите, мастер-лист.

Остальные 7 вкладок - это имена сотрудников группы.Я уже создал командную кнопку, которая будет искать в столбце C конкретное имя сотрудника и копировать всю строку, содержащую это имя, в отдельный рабочий лист соответствующего сотрудника.

Этот код работает нормально.Однако теперь мне нужно заставить его работать, чтобы он мог искать в том же столбце (C) имена оставшихся сотрудников и скопировать соответствующую строку в соответствующую рабочую таблицу.

Мой текущий код:

Private Sub CommandButton1_Click()
  Dim c As Range
  Dim j As Integer
  Dim Source As Worksheet
  Dim Target As Worksheet
  ' Change worksheet designations as needed
  Set Source = ActiveWorkbook.Worksheets("Front Page")
  Set Target = ActiveWorkbook.Worksheets("Charlotte")
  j = 2
  ' Start copying to row 2 in target sheet
  For Each c In Source.Range("C1:C1000") ' Do 1000 rows
    If c = "Charlotte Richardson" Then
      Source.Rows(c.Row).Copy Target.Rows(j)
      j = j + 1
    End If
  Next c
End Sub

Может кто-нибудь помочь с этим, пожалуйста ??

Спасибо!

Answer 1

Если бы вы назвали свои листы точным названием, которое вы ищете («Шарлотта Ричардсон» вместо «Шарлотта»), то вы могли бы использовать это:

Private Sub CommandButton1_Click()
  Dim c As Range
  Dim j As Integer, i As Integer
  Dim Source As Worksheet

  Set Source = ActiveWorkbook.Worksheets("Front Page")
  For i = 2 To ActiveWorkbook.Sheets.Count 'Assuming that "Front Page" is your first sheet
    j = 2
    ' Start copying to row 2 in target sheet
    For Each c In Source.Range("C1:C1000") ' Do 1000 rows
      If c.Value2 = ActiveWorkbook.Worksheets(i).Name Then
        Source.Rows(c.Row).Copy ActiveWorkbook.Worksheets(i).Rows(j)
        j = j + 1
      End If
    Next c
  Next
End Sub

Хорошая вещьЭто означает, что когда вам нужно добавить сотрудников, все, что вам нужно сделать, это добавить новый лист с правильным именем, и ваш код будет работать без каких-либо изменений.

Answer 2

Решение Array

Настоятельно рекомендуется создать копию исходного файла и сначала проверить там код.Откройте книгу и перейдите к SaveAs и сохраните ее под другим именем, например, «Тест» или что-то в этом роде.Теперь вы готовы «играть».

Перед использованием этого кода вам придется вручную ввести данные в разделе «Настройка» кода.

Такой код в идеале должен сохранять старые данные на семи листах и ​​обновлять только (добавлять новые строки), но он всегда удаляет (ClearContents) старые данные на семи листах, начиная со строки 2, перед добавлением новых данных,Более того, в коде нет обработки ошибок .

С другой стороны, код делает то, что должен делать.Если что-то пойдет не так, лист «Главная страница» не представляет опасности, поэтому, если что-то случится с другими листами, вы всегда можете создать их заново.

Private Sub CommandButton1_Click()
  Dim c As Range
  Dim i As Integer
  Dim j As Integer
  Dim Source As Worksheet
  Dim Target As Worksheet
  Dim arr() As String
  'Create an array of data
  ReDim arr(1 To 7, 1 To 2) As String
'-- Customize BEGIN --------------------
  'Sheet Names
  arr(1, 1) = "Charlotte"
  arr(2, 1) = ""
  arr(3, 1) = ""
  arr(4, 1) = ""
  arr(5, 1) = ""
  arr(6, 1) = ""
  arr(7, 1) = ""
  'Names in column 'C'
  arr(1, 2) = "Charlotte Richardson"
  arr(2, 2) = ""
  arr(3, 2) = ""
  arr(4, 2) = ""
  arr(5, 2) = ""
  arr(6, 2) = ""
  arr(7, 2) = ""
'-- Customize END ----------------------

  Set Source = ActiveWorkbook.Worksheets("Front Page")

  For i = 1 To 7
    j = 2
    Set Target = ActiveWorkbook.Worksheets(arr(i, 1))
    ' ClearContents of Target
    Target.Range(j & ":" & Target.Rows.Count).ClearContents
    ' Start copying to row 2 in target sheet
    For Each c In Source.Range("C1:C1000") ' Do 1000 rows
      If c = arr(i, 2) Then
        Source.Rows(c.Row).Copy Target.Rows(j)
        j = j + 1
      End If
    Next
  Next
End Sub

Чтобы полностью понять код, вы должны прочитать о массивах, циклах, диапазонах и любом ключевом слове, который вы видите в коде.

Answer 3

Попробуйте - хотя вам придется добавить имена таблиц в массив arr1 и полные имена, которые вы ищете в массив arr2:

Private Sub CommandButton1_Click()

    Dim c As Range
    Dim j As Long, i as Long
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim arr1 As Variant, arr2 As Variant

    arr1 = Array("Charlotte", "Mikey", "Bob")
    arr2 = Array("Charlotte Richardson", "Mikey Joe", "Bob Vann")

    'Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Front Page")

    'Start copying to row 2 in target sheet
    For i = 0 To UBound(arr1)

        j = 2
        Set Target = ActiveWorkbook.Worksheets(arr1(i))

        For Each c In Source.Range("C1:C1000") ' Do 1000 rows
            If c = arr2(i) Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c

    Next i

End Sub