Страницы: 1
RSS
Список по 4-м критериям из массива в одной книге, Список по 4-м критериям из массива в одной книге на разных листах
 
Добрый день. Задача стоит сделать из массива на листе Data, список на листе Заявка.
Список формируется по совпадению четырех критериев на листе Заявка (ФИО, Договор, Участок, месяц).
Начал писать макрос, пользуясь хелпом и гуглом, думал сделать через коллекцию с листа Data и споткнулся на этапе запуска коллекции.
И не понял как мне столбик с нужным месяцем указать.
Зарылся в гугле, запутался, решил спросить совета. Подобные темы искал, вероятно плохо, т.к. задача вроде не очень сложная.
Ткните меня пожалуйста носом, где почитать способы. Спасибо.
 
Добрый день. Можно таким макросом попробовать:
Код
Sub FillRequest()
    Dim lngI As Long, lngJ As Long, lngK As Long
    Dim arrIn, arrOut
    'пишем в массив диапазон с данными с листа Data
    arrIn = Worksheets("Data").UsedRange.Value
    With Worksheets("Заявка")
    'чистим старые данные заявки
    'Offset - отсупаем от В13 вправовниз, Resize - переопределяем размер диапазона, который чистим
    'строки считаем от размера CurrentRegion, столбцов для очистки = 2
        .Range("B13").Offset(1, 1).Resize(.Range("B13").CurrentRegion.Rows.Count - 1, 2).ClearContents
    'переопределяем размерность выходного массива, в который будем собирать данные
    'сколько строк может получиться по запросу не знаем, потому строк определяем столько же
    'сколько в исходном массиве. А столбцов нам нужно 2.
    ReDim arrOut(1 To UBound(arrIn, 1), 1 To 2)
    'запускаем 2 цикла - по строкам и по столбцам исходного массива
    For lngI = 2 To UBound(arrIn, 1)
        For lngJ = 5 To UBound(arrIn, 2)
            'если соблюдаются все равенства
            If arrIn(lngI, 1) = .Range("C8") And arrIn(lngI, 2) = .Range("C9") _
            And arrIn(lngI, 3) = .Range("C10") And arrIn(1, lngJ) = .Range("C11") Then
                'увеличиваем счетчик записей в выходном массиве
                lngK = lngK + 1
                'пишем значение в соответсвующую строку выходного массива
                arrOut(lngK, 1) = arrIn(lngI, 4): arrOut(lngK, 2) = arrIn(lngI, lngJ)
            End If
        Next lngJ
    Next lngI
    'пишем значения из массива в таблицу заявки
    'чтобы все значения влезли, переопределяем область, куда пишем через Resize
    'используя значение заполненных строк выходного массива и количество его столбцов
    .Range("C14").Resize(lngK, 2) = arrOut
    End With
End Sub
Кому решение нужно - тот пример и рисует.
 
Макрос в модуль листа Заявка, срабатывает при изменении ячеек C8:C11
В этих ячейках желательно сделать выпадающие списки
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("C8:C11")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundCell As Range
Dim FAdr As String
Dim FoundMonthCol As Integer
Dim iLastRow As Integer
  With Worksheets("Data")
   iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
   If iLastRow > 14 Then Range("C14:D" & iLastRow).ClearContents
    Set FoundCell = .Columns(1).Find(Range("C8"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then                                   'нашли ФИО
      FAdr = FoundCell.Address
      Do
        If FoundCell.Offset(, 1) = Range("C9") And FoundCell.Offset(, 2) = Range("C10") Then
          FoundMonthCol = .Rows(1).Find(Range("C11"), , xlValues, xlWhole).Column
          iLastRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
          Cells(iLastRow, "C") = FoundCell.Offset(, 3)                  'наименование
          Cells(iLastRow, "D") = .Cells(FoundCell.Row, FoundMonthCol)   'количество
        End If
         Set FoundCell = .Columns(1).Find(Range("C8"), After:=FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  End With
 End If
  Application.EnableEvents = True
End Sub
Изменено: Kuzmich - 14.01.2020 14:07:25
 
Если интересно, то предлагаю вариант решения на Power Query, без макросов. Таблица обновляется либо по кнопке "Обновить все" на вкладке данные, либо ПКМ по таблице после выбора фильтров и выбрать пункт "Обновить".
Изменено: PooHkrd - 14.01.2020 14:23:02
Вот горшок пустой, он предмет простой...
 
Спасибо Пытливый, добавил только переход при ошибке дальше, а то если нет данных ошибку выкидывал) за комментарии к коду отдельное огромное спасибо

Kuzmich,  спасибо, пошел пробовать и да, выпадающие списки по уникальным значениям надо сделать, закладку в браузере сделал, пойду пилить)

PooHkrd, спасибо огромное, попробую и так тоже
Изменено: kubuspb - 14.01.2020 14:37:42
Страницы: 1
Наверх