Макрос для выборки значений

[Nefet]

Здравствуйте! Помогите, пожалуйста. Имеется выгрузка из базы данных (пример в файле).
Необходимо из каждых 24 ячеек столбца D найти ячейку с максимальным значением, а значения ячеек из столбцов А, В и С, соответствующих максимальному значению ячейки в столбце D скопировать на новый лист.

Спасибо!

[pashulka]

Т.е. информация в столбце D идёт 'блоками' по 24 строки ? а то на скриншоте, размером с аватарку, лично я, ничего не вижу

[Nefet]

В столбце D информация идет "сплошняком", имею в виду, что пустых строк между "блоками" нет.
Файл .xls прикрепить нельзя, как я понимаю?

[pashulka]

Файл прикрепить можно, но в архиве.

Что касается Вашего макроса, то ежели в столбце D действительно наличествуют числа и нужно перебирать 'блоки' по 24 ячейки, то можете воспользоваться нижеопубликованным макросом, разумеется, указав своё имя рабочего листа и номер строки первой ячейки.

Код: Выделить всё

Private Sub Test()
    Dim iSourceWS As Worksheet, iCopyWS As Worksheet, iMaxValue#
    Dim tempSource As Range, tempCell As Range, iRow1&, iRow2&, iMaxRow&

    Set iSourceWS = Worksheets("Лист1") 'Укажите свой лист-источник данных
    Set iCopyToWS = Worksheets.Add(After:=iSourceWS) 'Структура книги не должна быть защищена
       
    iMaxRow = iSourceWS.Cells(iSourceWS.Rows.Count, 4).End(xlUp).Row
     
    Application.ScreenUpdating = False
    For iRow1 = 2 To iMaxRow Step 24 '2 - номер строки первой ячейки с данными
        Set tempSource = iSourceWS.Cells(iRow1, 4).Resize(24)
             
        iMaxValue = Application.Max(tempSource)
        Set tempCell = tempSource.Find(iMaxValue, , xlValues, xlWhole)(1, -2)
             
        iRow2 = iRow2 + 1: tempCell.Resize(, 3).Copy iCopyToWS.Cells(iRow2, 1)
    Next
    Application.ScreenUpdating = True
End Sub

Если же захочется сократить этот макрос и его "читабельность", то можно замутить следующее :

Код: Выделить всё

Private Sub Test2()
    Dim iSourceWS As Worksheet, iRow1&, iRow2&

    Set iSourceWS = Worksheets("Лист1"): Worksheets.Add

    Application.ScreenUpdating = False
    For iRow1 = 2 To iSourceWS.Cells(iSourceWS.Rows.Count, 4).End(xlUp).Row Step 24
        iRow2 = iRow2 + 1
        With iSourceWS.Cells(iRow1, 4).Resize(24)
             .Find(Application.Max(.Cells), , xlValues, xlWhole).Item(1, -2).Resize(, 3).Copy Cells(iRow2, 1)
        End With
    Next
    Application.ScreenUpdating = True
End Sub

P.S. Если возникнут проблемы с поиском чисел (метод Find), то, для начала, замените константу xlValues на xlFormulas