For a list like:
Column1 Column2 Column3
DataA 1 1234
DataA 2 4678
DataA 3 8910
DataB 2 1112
DataB 4 1314
DataB 9 1516
How do I get a list like this:
Column4 Column5 Column6
DataA 1 1234
DataB 2 1112
The key is to only return the minimum value in column2 and its corresponding column3 value.
Ben McCormack
31.8k46 gold badges145 silver badges221 bronze badges
asked Dec 9, 2009 at 20:08
4
Sorry I misunderstood your Question First. Here is a working code that ended up more complex than I wanted it to be 
Option Explicit
Private Function inCollection(ByRef myCollection As Collection, ByRef value As Variant) As Boolean
Dim i As Integer
inCollection = False
For i = 1 To myCollection.Count
If (myCollection(i) = value) Then
inCollection = True
Exit Function
End If
Next i
End Function
Sub listMinimums()
Dim source As Range
Dim target As Range
Dim row As Range
Dim i As Integer
Dim datas As New Collection
Dim minRows As New Collection
Set source = Range("A2:C5")
Set target = Range("D2")
target.value = source.value
For Each row In source.Rows
With row.Cells(1, 1)
If (inCollection(datas, .value) = False) Then
datas.Add .value
minRows.Add row.row, .value
End If
If (Me.Cells(minRows(.value), 2) > row.Cells(1, 2)) Then
minRows.Remove (.value)
minRows.Add row.row, .value
End If
End With
Next row
'output'
For i = 1 To minRows.Count
target(i, 1) = Me.Cells(minRows(i), 1)
target(i, 2) = Me.Cells(minRows(i), 2)
target(i, 3) = Me.Cells(minRows(i), 3)
Next i
Set datas = Nothing
Set minRows = Nothing
End Sub
Note: You might want to replace Me with the name of your sheet.
answered Dec 9, 2009 at 21:01
margmarg
2,7871 gold badge32 silver badges33 bronze badges
An example using ADO.
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer
''http://support.microsoft.com/kb/246335
strFile = ActiveWorkbook.FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT Column1, Min(Column3) As MinCol3 FROM [Sheet8$] GROUP BY Column1"
rs.Open strSQL, cn, 3, 3
For i = 0 To rs.fields.Count - 1
Sheets("Sheet7").Cells(1, i + 1) = rs.fields(i).Name
Next
Worksheets("Sheet7").Cells(2, 1).CopyFromRecordset rs
answered Dec 10, 2009 at 19:39
FionnualaFionnuala
90.1k7 gold badges110 silver badges148 bronze badges
2
Try this:
Public Sub MinList()
Const clColKey_c As Long = 1&
Const clColVal_c As Long = 3&
Dim ws As Excel.Worksheet, objDict As Object
Dim lRow As Long, dVal As Double, sKey As String
Dim lRowFrst As Long, lRowLast As Long, lColOut As Long
Set ws = Excel.ActiveSheet
Set objDict = CreateObject("Scripting.Dictionary")
lRowFrst = ws.UsedRange.Row
lRowLast = ws.UsedRange.Rows.Count
lColOut = ws.UsedRange.Columns.Count + 1&
For lRow = lRowFrst To lRowLast
dVal = Val(ws.Cells(lRow, clColVal_c).Value)
sKey = ws.Cells(lRow, clColKey_c).Value
If objDict.Exists(sKey) Then
If dVal > objDict.Item(sKey) Then objDict.Item(sKey) = dVal
Else
objDict.Add sKey, dVal
End If
Next
For lRow = lRowFrst To lRowLast
ws.Cells(lRow, lColOut).Value = objDict.Item(ws.Cells(lRow, clColKey_c).Value)
Next
ws.Cells(1&, lColOut).Value = "Min"
End Sub
answered Dec 11, 2009 at 13:35
OorangOorang
6,6001 gold badge34 silver badges52 bronze badges
all_angarsk, Вы меня не поняли. Я имел ввиду, что не нужно усложнять. Любой модуль/процедуру Вы легко отправите в экспорт на флэшку в формате *.bas. И так точно вытянете его оттуда в любом месте, на любом компе, в любой документ. А с модулем кнопки — тяжелее. Ну и с самой кнопкой — нарисуйте встроенными инстр-ми фигуру (или обьект WordArt) что Вам нравится, и назначьте ей нужную процедуру (правая кнопка > Назначить макрос (или как там у Вас по локализации)). Всего пару кликов. И практично, и веселее, и проще, а не унылая серость.
А про «…регулярные выражения…«. Что Вы имели ввиду? Я их там не вижу. 
Добавлено через 25 минут
Кажется, я понял про регулярку. Смотрите, у Тoiai грамотный и лаконичный код. Лично я бы все-таки сгенерированный массив выгрузил на лист, чтоб было видно. I.e., после next я бы добавил строку:
[a1].resize(1, ubound(a)).value=a
Дальше он вызывает окно сообщения MsgBox, в котором использует фукции не VBA, а Excel — Min и Max. Поэтому его тяжелая жизнь 
заставила вызывать их такими фразами Application.Max(a), Application.Min(a)…
Кстати, что б, если не нужно, не выкладывать массив на лист, его тоже можно одним движение загнать в этот же MsgBox.
I have a excel VBA macro which is to be used to calculate the size of a machined part. The first part of the macro is set up to obtain values from a worksheet and calculates an area based on some predefined options and prints them to excel. The second part is where I have some issues.
I have converted the table to a 2D array (save processing time) and started to fill in the array via 2 loops, 1 controls the row, 1 the column. Within the loop I am trying to find the minimum none zero value and the associated column, this then helps with the final part of the macro which works. I have also set the min number to be a large value which will never be exceeded.
When I run the macro step by step the first none zero value I come across resets the min value to zero and does not change the column number. Can anyone guide me as to where I have gone wrong?
maxtubesel = Sheets("Tube OD").Cells(Rows.Count, "R").End(xlUp).Row - 4
'Find min and col value in array
Dim resarray() As Long
ReDim resarray(maxtubesel, 5)
min = 1000000
col = 0
For m = 0 To 2 ' maxtubesel
For n = 0 To 4
resarray(m, n) = Sheets("Tube OD").Cells(4 + m, 26 + n)
If Sheets("Tube OD").Cells(4 + m, 26 + n) <> "" Or Sheets("Tube OD").Cells(4 + m, 26 + n) <> 0 Then
min = Sheets("Tube OD").Cells(4 + m, 26 + n) And col = n
End If
Next n
Next m
ТРЕНИНГИ
Быстрый старт
Расширенный Excel
Мастер Формул
Прогнозирование
Визуализация
Макросы на VBA
КНИГИ
Готовые решения
Мастер Формул
Скульптор данных
ВИДЕОУРОКИ
Бизнес-анализ
Выпадающие списки
Даты и время
Диаграммы
Диапазоны
Дубликаты
Защита данных
Интернет, email
Книги, листы
Макросы
Сводные таблицы
Текст
Форматирование
Функции
Всякое
Коротко
Подробно
Версии
Вопрос-Ответ
Скачать
Купить
ПРОЕКТЫ
ОНЛАЙН-КУРСЫ
ФОРУМ
Excel
Работа
PLEX
© Николай Павлов, Planetaexcel, 2006-2022
info@planetaexcel.ru
Использование любых материалов сайта допускается строго с указанием прямой ссылки на источник, упоминанием названия сайта, имени автора и неизменности исходного текста и иллюстраций.
Техническая поддержка сайта
|
ООО «Планета Эксел» ИНН 7735603520 ОГРН 1147746834949 |
ИП Павлов Николай Владимирович ИНН 633015842586 ОГРНИП 310633031600071 |
Поиск минимального элемента массива на VBA
Распространенной учебной задачей для тех, кто учится программировать, является программа поиска минимального элемента массива. Рассмотрим соответствующий алгоритм и его реализацию с помощью языка Visual Basic for Applications (VBA).
В качестве поставщика данных для работы программы будем использовать массив чисел, хранящихся на рабочем листе Excel в колонке А. То есть, в данном случае мы будем работать с одномерным массивом.
Алгоритм нахождения минимального элемента и его реализация на Visual Basic for Applications (VBA) подробно рассматривается в нашем видеоуроке. Также, комментарии ниже помогут вам в понимании изложенного материала.
Прежде чем переходить к программе, следует обговорить, какие действия нам необходимо будет выполнить.
Первое, с чего следует начать — это объявить одномерный массив А(10) с числом элементов, равным количеству чисел на рабочем листе Excel. В нашем случае, это 10. После создания такого массива, все его элементы хранят пустые значения, равносильные нулю.
Берем значение из ячейки «А1» рабочего листа и записываем его как элемент массива А(1), значение из ячейки «А2» записываем как элемент массива А(2). И так далее, пока не дойдем до последнего элемента «А10» -> А(10).
Сразу заметим, что заполнение массива числами — рутинная повторяющаяся операция, которую целесообразно оформить в виде циклической конструкции, которая бы автоматически выполнилась 10 раз.
Далее, давайте разберемся, что будет выступать в качестве результата работы программы? Как минимум, программа должна нам выдать наименьшее значение массива. Также неплохо было бы знать порядковый номер этого минимального элемента.
В переменной s_min = a(1) мы будем сохранять значение наименьшего элемента, а в переменной n = 1 — его порядковый номер. Что обозначают вот эти две строчки, идущие одна за другой?
s_min = a(1)
n = 1
Это означает, что программа запомнила первый элемент массива как минимальный и дальше будет его сравнивать со всеми остальными элементами. Кстати, в видеоуроке здесь допущена опечатка, обратите внимание. Вместо s_min = a(i) следует использовать команду s_min = a(1).
Переходим непосредственно к процедуре поиска наименьшего элемента массива. Для этого в программе также организуется цикл от 1 до 10 (с первого элемента, по последний).
Каждый i-ый элемент массива a(i) мы по-очереди сравниваем с тем, что хранится в переменной s_min. Если, вдруг, обнаруживается, что i-ый элемент массива меньше s_min, это означает, что мы нашли элемент, значение которого меньше того, что хранится у нас в памяти. Поэтому такой i-ый элемент следует запомнить как наименьший с помощью команд:
s_min = a(i)
n = i
По завершении работы цикла, необходимо не забыть вывести на экран найденное значение наименьшего элемента s_min, а также его порядковый номер.
Как сообщалось на нашем сайте ранее, с помощью встроенного в Microsoft Office языка программирования VBA вы можете реализовать арифметические операции.
Популярные сообщения из этого блога
Куда пропал редактор формул Microsoft Equation?
Работая в Microsoft Word , мне часто приходится набирать формулы. На протяжении многих лет, для этих целей я использовал встроенный в Word редактор формул Microsoft Equation . И даже, когда Microsoft добавил в свой Office новый инструмент » Формулы «, я все равно, по привычке, продолжал использовать Microsoft Equation . Для работы я использую два разных ноутбука с абсолютно одинаковым софтом. Microsoft Office 2010 у меня устанавливался на обоих компьютерах с одного дистрибутива. Каково же было мое удивление, когда однажды, открыв созданный ранее документ Word на втором ноутбуке, я не смог войти в режим редактирования формулы! То есть, документ открылся без проблем и все набранные ранее формулы отобразились корректно. Но когда мне понадобилось одну из них отредактировать, то оказалось, что Word этого сделать не может по причине отсутствия Microsoft Equation .
Что делать, если копируемый из Интернета текст не выравнивается по ширине
Каждый когда-либо сталкивался с ситуацией, когда скопированный из Интернета и вставленный в Word текст не удается выровнять по ширине: по левому краю выравнивает, по правому — тоже, а вот по ширине — ни в какую. Еще хуже обстоят дела, если вы захотите увеличить размер шрифта: выравнивание текста окончательно откажется работать. Разбираемся в причинах и ищем способ, как это исправить.
Как отсортировать сотрудников по дням рождения в Excel
Актуальная задача для любого коллектива — не пропустить день рождения каждого сотрудника. Стандартная сортировка списка сотрудников в Excel по дате их рождения не решает поставленной задачи, поскольку такая сортировка выстраивает их в хронологическом порядке, с учетом не только дня и месяца, но и года рождения. В результате такой сортировки мы будем видеть, кто из сотрудников старше или моложе. А вот, чтобы сказать, у кого скоро будет день рождения — для этого придется вручную просматривать от начала до конца весь список, что неудобно.