Страницы: 1
RSS
Собрать данные в массив по условию и найти максимальное/минимальной значение в массиве
 
Добрый день
Нужна помошь
Нужно сабрать в массив данные по условию:
на листе 222 даты соотвествующие порядковому номеру на листе 111 и определить среди них максимальное/минимальной
Как ни пробовал у меня одни нули в массиве...
Код
Sub Date_found2()
Dim Arr_1() As Variant, Arr_2() As Variant, _
x As Long, y As Long, LastRow_x As Long, LastRow_y As Long
Dim N As Integer
N = 0
'On Error Resume Next
    LastRow_x = Worksheets("111").Cells(2, 1).End(xlDown).Row
    LastRow_y = Worksheets("222").Cells(3, 1).End(xlDown).Row
    For x = 2 To LastRow_x
        For y = 3 To LastRow_y
            If Worksheets("222").Cells(y, 1) Like Worksheets("111").Cells(x, 1) Then
                N = N + 1
                ReDim Preserve Arr_1(N)
                Arr_1(N) = Worksheets("222").Cells(y, 2).Value
                ReDim Preserve Arr_2(N)
                Arr_2(N) = Worksheets("222").Cells(y, 3).Value
            End If
        Next y
        Worksheets("111").Cells(x, 2) = Application.Min(Arr_1)
        Worksheets("111").Cells(x, 3) = Application.Max(Arr_2)
        Erase Arr_1
        Erase Arr_2
    Next x
'On Error GoTo 0
End Sub
Изменено: narod svs - 19.09.2020 11:47:15
 
Не могу понять, по какому условию нужно формировать массив. И в сообщении Вы пишете про массив (ОДИН массив), а в коде формируете два массива. Зачем два? Разве из одного нельзя извлечь мин и макс?
 
Цитата
Не могу понять, по какому условию нужно формировать массив. И в сообщении Вы пишете про массив (ОДИН массив), а в коде формируете два массива. Зачем два? Разве из одного нельзя извлечь мин и макс?
Это файл для примера...
На листе 111 есть стобец с порядковыми номерами
На листе 222 этим порядковым номерами (которые могут повторяться несколько раз) соответсвуют даты начала Н и конца К
Надо собрать в массив сперва все даты соттвествующие номеру 1 на листе 222 в стоблце Н, из них определить минимальное и записать это значение на листе 111 напротив номера 1 в стобец Н,
потом все даты соттвествующие номеру 1 на листе 222 в стоблце К, из них определить максимальное и записать это значение на листе 111 напротив номера 1 в столбец К
и так со всеми номераими на листе 111

P.S.: я так понимаю что еще надо добавить очистку массивов после каждого выполнения полного цикла по Y
Изменено: narod svs - 19.09.2020 12:13:27
 
narod svs, а зачем Вы меня процитировали? Если полагаете, что я забыл, о чём писал, то я в состоянии перечитать свой пост. Зачем цитата? Да и не цитата это, а полная копия моего сообщения.
Запомните: кнопка цитирования не для ответа.
Если нужно проверить соответствие по номеру, например, 1, то зачем Like? Почему не "="?
 
Вообще пример плохой, потому что исходя из него можно написать код, который будет корректно работать только для этого примера.
Например по такой логике:
1. берём в двумерный массив диапазон A2:C6 первого листа
2. цикл по ячейкам столбца А второго листа, по номеру обращаемся к массиву, сверяем его значения с текущими второго листа (0 не считаем за минимальную дату), записываем или не записываем в массив
3. выгружаем массив назад
Всё.
Но если номера в первом листе другие и хаотичные - тогда просто в код добавить словарь, куда сперва занести все эти номера с их позицией в массиве, и использовать эту информацию в дальнейшем.
Изменено: Hugo - 19.09.2020 11:58:59
 
Цитата
Если нужно проверить соответствие по номеру, например, 1, то зачем Like? Почему не "="?
Это для примера "номера", в конечном итоге будет проверяться наличие "фразы" в тексте ячейки, по этому и Like
Цитата
берём в двумерный массив диапазон A2:C6 первого листа
да, может пример и плахой... в конечном счете все будет выглядеть иначе, и количество столбцов разное, и рабочие книги разные, но смысл схожий: найти все даты в Книге 2 советующие искомому значению в Книге1, определить из первого диапазона минимальную дату, из второго диапазона максимальную дату. И все это повторить для всех указанных строк Книги 1

Я просто стремился упростить саму задачу, с сохранением самого смысла
 
А что писать в итоговые даты, если значение не найдено?
 
Просмотрел кучу форумов, как собирать массивы по условию... Но у меня почему-то одни нули((( Пробовал и с использованием Collection... В Collection все собирается, а из Collection в array только нули...
Код
Sub Date_found()
Dim Coll_1 As New Collection, Coll_2 As New Collection, Arr_1() As Variant, Arr_2() As Variant, _
x As Long, y As Long, i As Long, LastRow_x As Long, LastRow_y As Long
'On Error Resume Next
    LastRow_x = Worksheets("111").Cells(2, 1).End(xlDown).Row
    LastRow_y = Worksheets("222").Cells(3, 1).End(xlDown).Row
    For x = 2 To LastRow_x
        For y = 3 To LastRow_y
            If Worksheets("222").Cells(y, 1) Like "*" & Worksheets("111").Cells(x, 1) & "*" Then
                Coll_1.Add Worksheets("222").Cells(y, 2).Value
                Coll_2.Add Worksheets("222").Cells(y, 3).Value
            End If
        Next y
            ReDim Arr_1(1 To Coll_1.Count)
            For i = 1 To Coll_1.Count
                Arr_1(i) = Coll_1(i)
            Next i
            ReDim Arr_2(1 To Coll_2.Count)
            For i = 1 To Coll_2.Count
                Arr_2(i) = Coll_2(i)
            Next i
        Worksheets("111").Cells(x, 2) = Application.Min(Arr_1)
        Worksheets("111").Cells(x, 3) = Application.Max(Arr_2)
        Erase Arr_1
        Erase Arr_2
    Next x
'On Error GoTo 0
End Sub
 
Цитата
А что писать в итоговые даты, если значение не найдено?
"" - пустоту
 
Я описал вроде оптимальный алгоритм, осталось Вам его реализовать. И не нужны кучи массивов. достаточно одного с результатом и одного с исходными данными.
Ну и может ещё коллекции или словаря с индексами.
 
Вот кусок итоговой таблица.
Получится с ней сделать то что вы предлагаете? Сам я не пойму как это сделать...
Код
Sub Number_Otchet()
Dim Arr_1() As Variant, Arr_2() As Variant, _
x As Long, y As Long, LastRow_x As Long, LastRow_y As Long
Dim N As Integer
N = 0
    LastRow_x = Worksheets("Sponge_Test_Pipe").Cells(4, 2).End(xlDown).Row
    LastRow_y = Worksheets("DATA_REPORT").Cells(6, 2).End(xlDown).Row
    For x = 4 To LastRow_x
        For y = 6 To LastRow_y
            If Worksheets("DATA_REPORT").Cells(y, 4) Like "*" & Worksheets("Sponge_Test_Pipe").Cells(x, 3) & "*" Then
                N = N + 1
                ReDim Preserve Arr_1(N)
                Arr_1(N) = Worksheets("DATA_REPORT").Cells(y, 18).Value
                ReDim Preserve Arr_2(N)
                Arr_2(N) = Worksheets("DATA_REPORT").Cells(y, 51).Value
            End If
        Next y
        Worksheets("Sponge_Test_Pipe").Cells(x, 13) = Application.Min(Arr_1)
        Worksheets("Sponge_Test_Pipe").Cells(x, 14) = Application.Max(Arr_2)
        Erase Arr_1
        Erase Arr_2
    Next x
End Sub
на листе DATA_REPORT надо найти значения в столбцах 18 и 51 к тем строкам столбца 4, в которых есть совпадения со строкой столбца 3 листа Sponge_Test_Pipe и вывести из этих данных минимальное значение в столбец 13 листа Sponge_Test_Pipe, а максимальное в столбец 14 листа Sponge_Test_Pipe
Изменено: narod svs - 19.09.2020 13:53:23 (Исправил ошибки в коде)
 
Если совпадение только частичное - тогда словарь тут не годится, цикл в цикле наверное придётся перебирать...
Хотя в словаре можно хранить номера строк массива с этими критериями, а сравнивать перебором ключей словаря, так можно/нужно его использовать.
Я сегодня пас, нет времени вникать/делать.
Изменено: Hugo - 19.09.2020 14:31:49
 
Цитата
narod svs написал:
Нужно сабрать в массив данные по условию:
Какую задачу вы решаете? А то, может, по ходу, никаких массивов собирать и не нужно?
 
По тому, что я понял из файла, как-то так:
Код
Sub Data_Find()
    Dim DatMin As Date, DatMax As Date, Arr()
    Dim Cel As Range, Rn As Range, i&, C1&, C2&
    With Sheets("DATA_REPORT")
        Arr = .Range(.Cells(7, 4), .Cells(Rows.Count, 4).End(xlUp).Offset(0, 51 - 4)).Value
    End With
    C1 = 18 - 4 + 1
    C2 = 51 - 4 + 1
    With Sheets("Sponge_Test_Pipe")
        Set Rn = .Range(.Cells(4, 3), .Cells(Rows.Count, 3).End(xlUp))
        For Each Cel In Rn
            DatMin = Date
            DatMax = CDate("1/1/1900")
            For i = 1 To UBound(Arr)
                If Arr(i, 1) Like "*" & Cel.Value & "*" Then
                    If Arr(i, C1) < DatMin Then DatMin = Arr(i, C1)
                    If Arr(i, C2) > DatMax Then DatMax = Arr(i, C2)
                End If
            Next
            Cel.Offset(0, 10) = DatMin
            Cel.Offset(0, 11) = DatMax
        Next
    End With
End Sub
Изменено: Михаил Витальевич С. - 19.09.2020 18:10:01
 
Вот нарисовал что надо получить
Изменено: narod svs - 19.09.2020 17:35:12
 
Цитата
По тому, что я понял из файла, как-то так:
Спасибо, не много не то...
Надо чтобы для каждой строки находил отдельно наибольшее и наименьшее значение из диапазона
 
посмотрите файл; макрос в Module2
в файле макрос чуть изменил, в сообщении выше - тоже
Цитата
narod svs написал:
Надо чтобы для каждой строки находил отдельно наибольшее и наименьшее значение из диапазона
ну так и ищет
Изменено: Михаил Витальевич С. - 19.09.2020 18:11:50
 
Цитата
Михаил Витальевич С. написал:
посмотрите файл; макрос в Module2
Спасибо, то что надо.
 
только надо проверки добавить, на случай если совпадений нет
 
Цитата
только надо проверки добавить, на случай если совпадений нет
если так?
Код
If Not DatMin = Date Then Cel.Offset(0, 10) = DatMin Else Cel.Offset(0, 10) = ""
If Not DatMax = CDate("1/1/1900") Then Cel.Offset(0, 11) = DatMax Else Cel.Offset(0, 11) = ""
 
Цитата
narod svs написал:
если так?
можно, но я б сделал немного по другому:
Код
If DatMin < Date Then Cel.Offset(0, 10) = DatMin Else Cel.Offset(0, 10) = Empty
If DatMax > CDate("1/1/1900") Then Cel.Offset(0, 11) = DatMax Else Cel.Offset(0, 11) = Empty

мало чем отличается от вашего варианта; но в любом случае Empty (пустая ячейка) лучше, чем "" (текст длиною ноль символов)
 
Цитата
Михаил Витальевич С. написал:
мало чем отличается от вашего варианта; но в любом случае Empty (пустая ячейка) лучше, чем "" (текст длиною ноль символов)
Спасибо
Страницы: 1
Наверх