Vba excel найти минимальное значение - Word и Excel - помощь в работе с программами

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

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

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

Источник

Egor M.

Пользователь

Сообщений: 21
Регистрация: 11.07.2015

Добрый день.
Прошу вас помочь написать макрос, который сравнивает значения в в ячейках
построчно (начиная со второй строки и до конца вниз) в столбцах с F по K и находит минимальное значение, исключая: 0, пусто, нет данных.
Найденное значение покрасить в найденной ячейке и скопировать его в ячейку в столбце D соответствующей строки.
Файл-пример прикрепил.
Заранее спасибо.

Прикрепленные файлы

primer.xls (34.5 КБ)

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

Не макросом принимается?
Формула массива, ввдится Ctrl+Shift+Enter:
=МИН(ЕСЛИ(F2:K38>0;F2:K38))
Обычная, без массивности:
=НАИБОЛЬШИЙ(F2:K38;СЧЁТЕСЛИ(F2:K38;»>0″))
Если показать минимальное в нужной строке:
=ЕСЛИ(НАИБОЛЬШИЙ(F2:K2;СЧЁТЕСЛИ(F2:K2;»>0″))=НАИБОЛЬШИЙ($F$2:$K$38;СЧЁТЕСЛИ($F$2:$K$38;»>0″));НАИБОЛЬШИЙ(F2:K2;СЧЁТЕСЛИ(F2:K2;»>0″));»»)

Egor M. Пользователь Сообщений: 21 Регистрация: 11.07.2015	Vikttur, спасибо, но мне нужен именно макрос, который будет срабатывать на событие в листе в столбцах F:K.

МВТ

Пользователь

Сообщений: 1198
Регистрация: 01.02.2015

11.07.2015 15:33:59

Как-то так (а подкрашивание через УФ сделайте)

Код

Sub tt()
Dim L As Long: L = Cells(Rows.Count, 1).End(xlUp).Row
Dim I As Long, J As Integer
Dim arr
For I = 1 To L
arr = Range("F" & I & ":K" & I)
For J = 1 To UBound(arr, 2)
If arr(1, J) <= 0 Then arr(1, J) = Application.WorksheetFunction.Max(arr)
Next J
Cells(I, 4) = Application.WorksheetFunction.Min(arr)
Next I
End Sub

JeyCi

Пользователь

Сообщений: 3357
Регистрация: 27.11.2013

11.07.2015 17:17:07

Цитата
vikttur написал: =МИН(ЕСЛИ(F2:K38>0;F2:K38))

а я думала, это только я ТАК подумала/поняла…
а ТС поблагодарил

vikttur

‘а, и попросил макрос…

Цитата
Egor M. написал: спасибо, но мне нужен именно макрос, который будет срабатывать на событие в листе в столбцах F:K.

вот и получилось у меня ТО ЖЕ САМОЕ (видимо, не совсем то —
но работает по-своему — хотя, наверно, Target не очень указан — пока в задумчивости)

Скрытый текст

МОРАЛЬ: ветку вести аккуратно, головой отвечать за каждое слово, ТЗ описывать последовательно (!), не ссылаясь на файл, который ещё не открыли и среди кучи цифр не выискивали не то — что бы хотелось ТСу!? переписывать не буду
(Target поправить бы — но только, когда пойму как)…

МВТ

ответил за всех (похоже, внимательно читал название ветки), чем я иногда грешу, читая описание проблемы… написанное удалять уже жаль — посему запихнула под спойлер (до лучших времён)

Изменено: JeyCi — 11.07.2015 17:32:15

чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок — обратитесь к собеседнику на ВЫ — ответ на ваш вопрос получите — а остальное вас не касается (п.п.п. на форумах)

МВТ Пользователь Сообщений: 1198 Регистрация: 01.02.2015	JeyCi, осталось дождаться ответа ТС, чтобы понять, что он имел в виду на самом деле

Egor M.

Пользователь

Сообщений: 21
Регистрация: 11.07.2015

Вобщем-то вы почти все и сделали, что ТС имел ввиду (не знаю только Тэ эС или ТиСи — я не в тренде).
МВТ спасибо, Ваш макрос работает почти как надо — делает все , только красит в УФ, а хотелось бы ПвМ.
Макрос JeyCi не сработал. Наверное из-за непоправленного Target. Если таргет это тот диапазон, на изменения в котором макрос начинает заводиться,
то тогда Target это от F2 до K-последняя строка. Пожалуйста, подправьте макрос. Я хочу его, т.к. он идет сразу в листик.
Спасибо.

JeyCi

Пользователь

Сообщений: 3357
Регистрация: 27.11.2013

12.07.2015 09:21:04

Цитата
Egor M. написал: Макрос JeyCi не сработал.

он же Private Sub Worksheet_Change

Цитата
Egor M. написал: мне нужен именно макрос, который будет срабатывать на событие в листе

а у Вас Событие Изменения на Листе произошло? чтобы так заявлять… т е войдите в любую ячейку и нажмите Enter… подсветит значение по формуле от

vikttur

Цитата
Egor M. написал: сравнивает значения в в ячейках — построчно (начиная со второй строки и до конца вниз) в столбцах с F по K и находит минимальное значение. Найденное значение покрасить в найденной ячейке

может вам вообще не то событие надо и надо ли вообще?..

Цитата
Egor M. написал: Пожалуйста, подправьте макрос. Я хочу его, т.к. он идет сразу в листик

а УФ находится сразу в Excel… зачем мне работать за разработчиков Microsoft? — если они уже организовали все удобства по вопросу — надо брать и пользоваться — Excel’ем… я просто сторонница оптимальности решений, а не соревнований с Microsoft :oops:
p.s.

Код

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, RN As Range, lr&, m As Range, min As Double
With Application: DisplayAlerts = False: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
     
    With ActiveSheet
    lr = .Cells(.Rows.Count, "F").End(xlUp).Row
    End With
     
    Set Rng = ActiveSheet.Range("F2:K" & lr)
    If Not Rng Is Nothing Then
    Rng.Interior.ColorIndex = xlNone
    
    For rr = 1 To Rng.Rows.Count + 1
   min = 1000 ' исходя из данных любое большое число
 
        For Each RN In Rng.Rows(rr).Cells
            If (IsNumeric(RN.Value) And RN.Value <> 0 And RN.Value <= min) Then
            min = RN.Value: Set m = RN
            Else: min = min
            End If
        Next RN
        m.Interior.ColorIndex = 6
    Next
    End If
With Application: DisplayAlerts = True: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
End Sub

переписывать не буду (т к формулу от

vikttur

можете сами адаптировать под каждую конкретную строку)… да и вообще без событий, похоже, хотите — чтобы само всё работало (и подправлялось кем-то) — не бывает так — если хотите, чтобы работало так, как надо ! вам — приложите усилия (кроме фразы «я хочу»)
P.P.S
просто оптимальное решение — это то, что экономит время для др полезных дел, а не чужими руками творит бог весть знает что
— но мы с

МВТ

вроде бы натворили — если соединить наши 2 кода…

Изменено: JeyCi — 12.07.2015 11:09:15

Egor M.

Пользователь

Сообщений: 21
Регистрация: 11.07.2015

Прошу прощения, но я совершенно не хотел отнять Ваше время. Просто на входе в форум написано,
что каждый входящий сюда может рассчитывать на помощь форумчан на добровольной основе.
Соответственно я посчитал, что тоже могу сюда войти, и если кто-то захочет, то поможет мне в моем вопросе, а то и в просьбе.
А теперь получается, что Вы себе в напряг написали столько текста, решили за мой вопрос свою задачу как Вам было удобнее.
А люди, которым несложно было сделать то, что я просил, подумают что вопрос решен и пройдут мимо моей темы.
А вопрос-то в две строчки…

JeyCi

Пользователь

Сообщений: 3357
Регистрация: 27.11.2013

#10

12.07.2015 14:08:59

Цитата
Egor M. написал: А теперь получается, что Вы себе в напряг написали столько текста,

вам в помощь

Цитата
Egor M. написал: , решили за мой вопрос свою задачу как Вам было удобнее.

как вопрос поставлен, такая задача и решалась

Цитата
Egor M. написал: каждый входящий сюда может рассчитывать на помощь форумчан на добровольной основе. Соответственно я посчитал, что тоже могу сюда войти, и если кто-то захочет, то поможет мне в моем вопросе, а то и в просьбе.

пошла подмена понятий… в программировании это не проходит

Цитата
Egor M. написал: А вопрос-то в две строчки…

теперь после всего написанного — уже в одну строчку и один нюанс… как из одного макроса выйти в др макрос…

Цитата
Egor M. написал: А люди,…, подумают что вопрос решен и пройдут мимо моей темы.

… вы уверены, что верно рассчитываете?.. программисты Microsoft тоже рассчитывают, что их функционал даст людям больше возможностей для оптимальной автоматизации работы — если в полном объёме использовать те возможности, которые даёт Excel, а не создавать Америку с нуля… и добровольная помощь рассчитывает, что если вы задаёте вопрос — то имеете потенциал или хотя бы приложите усилия, чтобы понять ответ…

p.s. вам помогли задуматься о возможностях эффективного использования имеющихся ресурсов для разработки наилучшего решения, а вы даже не подумали, что вопрос может быть решён намного лучше, чем вам кажется… вы написали

Цитата
Egor M. написал: Пожалуйста, подправьте макрос. Я хочу его

— вам даже подправили его… хотя место «хотеть» находится

ЗДЕСЬ

…

Цитата
Egor M. написал: Прошу вас помочь написать макрос Найденное значение покрасить в найденной ячейке и скопировать его в ячейку в столбце D соответствующей строки.

что ещё не сделали за вас? что сделали вы? на добровольной основе — Просто на входе в форум ещё написано,

Цитата
2.7. Если вам нужен не совет по самостоятельному решению задачи, а чтобы все сделали за вас — добро пожаловать в ветку Работа

МВТ

Пользователь

Сообщений: 1198
Регистрация: 01.02.2015

#11

12.07.2015 15:37:05

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

Код

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
Application.EnableEvents = False
Dim I As Long, J As Integer
Dim arr
I = Target.Row
arr = Range("F" & I & ":K" & I)
For J = 1 To UBound(arr, 2)
If arr(1, J) <= 0 Then arr(1, J) = Application.WorksheetFunction.Max(arr)
Next J
Cells(I, 4) = Application.WorksheetFunction.Min(arr)
Application.EnableEvents = True
End Sub

P.S. а чем Вас все-таки не устраивает УФ — просто любопытно?

Изменено: МВТ — 12.07.2015 15:42:10

sv2013

Пользователь

Сообщений: 657
Регистрация: 09.06.2015

#12

12.07.2015 17:00:13

EgorM,могу предложить два макроса,первый макрос решает ваш вопрос,
второй макрос убирает заливку,если это необходимо.

Код

Sub search()
Dim s As Double, I&, J&, n&, addr$
  n = Range("D2").End(xlDown).Row
For J = 2 To n
 s = Application.Max(Range("G" & J & ":K" & J))
  For I = 1 To 5
  If Range("G" & J & ":K" & J).Cells(I) < s And Range("G" & J & ":K" & J).Cells(I) <> 0 Then
    s = Range("G" & J & ":K" & J).Cells(I)
  End If
  Next I
   Range("D" & J) = s
   addr = Range("G" & J & ":K" & J).Find(s).Address
   Range(addr).Interior.ColorIndex = 3
Next J
End Sub

Код
Sub test1() Dim J&, n& n = Range("D2").End(xlDown).Row For J = 2 To n Range("G" & J & ":K" & J).Interior.Color = xlNone Next J End Sub

Sanja

Пользователь

Сообщений: 14838
Регистрация: 10.01.2013

#13

12.07.2015 18:59:44

Вариант со словарем.
И покраской ячейки

Код

Private Sub Worksheet_Change(ByVal Target As Range)
Set arrRange = Range("F2:K" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not Intersect(Target, arrRange) Is Nothing And Target.Count = 1 Then
On Error Resume Next
arrRange.Interior.ColorIndex = xlNone
Set oDict = CreateObject("Scripting.Dictionary")
For Each cl In arrRange.Cells
    If IsNumeric(cl) And cl <> 0 Then
        oDict.Add Item:=cl.Address, Key:=cl.Value
    End If
Next
minVal = Application.WorksheetFunction.min(oDict.Keys)
With Range(oDict.Item(minVal))
    .Interior.ColorIndex = 6
    Cells(.Row, 4) = minVal
End With
End If
End Sub

Согласие есть продукт при полном непротивлении сторон.

Юрий М Модератор Сообщений: 60575 Регистрация: 14.09.2012 Контакты см. в профиле	sv2013, а зачем во втором макросе цикл?

sv2013

Пользователь

Сообщений: 657
Регистрация: 09.06.2015

#15

12.07.2015 22:39:05

Добрый вечер,можно ,конечно, без цикла обойтись,во вспомогательном втором макросе.
С уважением ко всем участникам обсуждения.

Код
Sub test2() Dim n& n = Range("D2").End(xlDown).Row Range("G2:K" & n).Interior.Color = xlNone End Sub

Sanja

Пользователь

Сообщений: 14838
Регистрация: 10.01.2013

#16

12.07.2015 22:53:47

Я, похоже, то-же подумал/понял как vikttur, а ТС продолжает интриговать

Цитата
Egor M. написал: подумают что вопрос решен и пройдут мимо моей темы

так решен вопрос или нет?
на всякий случай вариант «как у всех», но с другой WorksheetFunction

Код

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F2:K" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing And Target.Count = 1 Then
On Error Resume Next
Application.EnableEvents = False
With Target
    Set arrRow = Range("F" & .Row & ":K" & .Row)
    arrRow.Interior.ColorIndex = xlNone
    For I = 1 To arrRow.Count
        minVal = Application.WorksheetFunction.Small(arrRow, I)
        If minVal <> 0 Then
            Set minCell = arrRow.Find(minVal)
            minCell.Interior.ColorIndex = 6
            Cells(.Row, 4) = minVal
            Exit For
        End If
    Next
End With
Application.EnableEvents = True
End If
End Sub

Согласие есть продукт при полном непротивлении сторон.

Egor M.

Пользователь

Сообщений: 21
Регистрация: 11.07.2015

Ничего общего с интригой. Просто столько вариантов дали. Надо ж было потестировать.
Sanja, Ваш симпатичный вариант не заработал, т.е. макрос не реагировал на изменения в ячейках.
А ,,как у всех,, реагирует на изменения только в одной ячейке, а если вставлять в столбец оптом, молчит.
SV2013 макрос запинается на строчке addr = Range(«G» & J & «:K» & J).Find(s).Address . Я его проверял не на файле-примере. а на большом файле.
Он доходит до первой пустой ячейки и останавливается.
МВТ, в вашем макросе тоже идет реакция только на 1 ячейку, а если вставлять данные оптом, то макрос записывает в ячейку столбца D только данные
из первой строчки вставленного диапазона. И еще момент: если при первом вычислении в строке макрос и вычисляет и красит, то при втором изменении в той же
строке макрос перекраской себя уже не утруждает. Вы спрашивали про нелюбовь к УФ — не могу внятно ответить. Как-то УФ не вселяет в меня уверенность, видимо от редкого использования.

В итоге я из каждого макроса понадергал по чуть-чуть (включая макрос от JeyCi) и у меня теперь все работает, как я и просил.
Считаю, что задача решена. Большое вам всем спасибо.
ТС (Егор М.)

Юрий М

Модератор

Сообщений: 60575
Регистрация: 14.09.2012

Контакты см. в профиле

#18

13.07.2015 08:09:26

Цитата
Egor M. написал: Sanja, Ваш симпатичный вариант не заработал, т.е. макрос не реагировал на изменения в ячейках

А Вы куда скопировали код? Подозреваю, что в стандартный модуль, а нужно в модуль листа.

SAS888

Пользователь

Сообщений: 757
Регистрация: 01.01.1970

#19

13.07.2015 08:59:36

Предложу еще один вариант. Вообще без циклов.
В модуль листа:

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x As Range, y As Range
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, [F:K]) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    Set x = Intersect(Rows(Target.Row), [F:K])
    x.Interior.ColorIndex = xlNone
    x.Replace 0, "qq", xlWhole
    Set y = x.Find(Application.Min(x.Value))
    If y Is Nothing Then
        Cells(Target.Row, "D") = ""
    Else
        y.Interior.ColorIndex = 3: Cells(y.Row, "D") = y
    End If
    x.Replace "qq", 0, xlWhole
    Application.EnableEvents = True
End Sub

Пример во вложении.

Прикрепленные файлы

primer_2.xls (39 КБ)

Чем шире угол зрения, тем он тупее.

Sanja

Пользователь

Сообщений: 14838
Регистрация: 10.01.2013

#20

13.07.2015 09:45:56

Цитата
Egor M. написал: а если вставлять в столбец оптом, молчит.

Egor M., что Вам мешало в стартовом сообщении указать что изменение ячеек происходит копи-пастом, причем оптом?
З.Ы. ТС — Топик Стартер.

Согласие есть продукт при полном непротивлении сторон.

Egor M.

Пользователь

Сообщений: 21
Регистрация: 11.07.2015

#21

13.07.2015 09:59:08

Цитата
А Вы куда скопировали код? Подозреваю, что в стандартный модуль, а нужно в модуль листа

Чесслово вставил , куда следовало. В лист, в самую его нежную часть. Сейчас перепроверил — нет, не работает.

sv2013

Пользователь

Сообщений: 657
Регистрация: 09.06.2015

#22

13.07.2015 10:15:06

Egor M,попробуйте на вашем другом файле:

Код

Sub search2()
Dim s As Double, I&, J&, n&, addr$
  n = Range("D2").End(xlDown).Row
For J = 2 To n
 s = Application.Max(Range("G" & J & ":K" & J))
  For I = 1 To 5
  Set x = Range("G" & J & ":K" & J).Cells(I)
  If x.Value < s And x.Value <> 0 And Not IsEmpty(x) Then
    s = x.Value
  End If
  Next I
   Range("D" & J) = s
   addr = Range("G" & J & ":K" & J).Find(s).Address
   Range(addr).Interior.ColorIndex = 3
Next J
End Sub

Egor M.

Пользователь

Сообщений: 21
Регистрация: 11.07.2015

#23

13.07.2015 10:33:30

Цитата
Egor M., что Вам мешало в стартовом сообщении указать что изменение ячеек происходит копи-пастом, причем оптом? З.Ы. ТС — Топик Стартер.

Помешало отсутствие кругозора. Я считал, что если есть на свете копи-паст, то руками заносить данные никто не станет. Ошибался. А ТС оказалось вовсе не обидно, как могло показаться в начале.

Обязательно сегодня вечером проверю все новые макросы.

JeyCi

Пользователь

Сообщений: 3357
Регистрация: 27.11.2013

#24

13.07.2015 10:40:32

Цитата
sv2013 написал: Application.Max(Range(«G» & J & «:K» & J))

— так лучше, чем было у меня… в код поста №8 точно лучше вставить в строку14

Код
min = Application.max(Rng.Cells) 'вместо 1000

p.s.

sv2013

почему вы вместо F столбца (как заказывал ТС) — по всем кодам заглядываетесь на G столбец?..

Изменено: JeyCi — 13.07.2015 10:51:15

sv2013

Пользователь

Сообщений: 657
Регистрация: 09.06.2015

#25

13.07.2015 11:53:58

Jeyci,добрый день,с учетом вашей корректировки:
Спасибо за просмотр кода.С уважением.

Код

Sub search3()
Dim s As Double, I&, J&, n&, addr$,x As Range
  n = Range("D2").End(xlDown).Row
For J = 2 To n
 s = Application.Max(Range("F" & J & ":K" & J))
  For I = 1 To 6
  Set x = Range("F" & J & ":K" & J).Cells(I)
  If x.Value < s And x.Value <> 0 And Not IsEmpty(x) Then
    s = x.Value
  End If
  Next I
   Range("D" & J) = s
   addr = Range("F" & J & ":K" & J).Find(s).Address
   Range(addr).Interior.ColorIndex = 3
Next J
End Sub

Код
Sub test2() Dim n& n = Range("D2").End(xlDown).Row Range("F2:K" & n).Interior.Color = xlNone End Sub

Прикрепленные файлы

example11_07_2015.xlsm (19.13 КБ)

Изменено: sv2013 — 13.07.2015 12:30:43

Egor M. Пользователь Сообщений: 21 Регистрация: 11.07.2015	SAS888, на копи-пейст макрос перестает трудиться. А если по каждой ячейке пройтись, то все отлично работает. Спасибо.

SAS888

Пользователь

Сообщений: 757
Регистрация: 01.01.1970

Речь о том, что требуется обрабатывать множество ячеек зашла лишь после того, как я опубликовал свой пример.
Поэтому, при копировании — вставке, макрос обработки события будет немного другой (см. вложение).

Чем шире угол зрения, тем он тупее.

Egor M. Пользователь Сообщений: 21 Регистрация: 11.07.2015	sv2013: все-равно ругается на строчку: addr = Range(«F» & J & «:K» & J).Find(s).Address. Я подумал, что может это из-за строчки : n = Range(«D2»).End(xlDown).Row. Я исправил на подсчет строк по столбцу «A», но это не помогло.

Egor M. Пользователь Сообщений: 21 Регистрация: 11.07.2015	SAS888, Вот теперь самое оно. Благодарю Вас.

Egor M. Пользователь Сообщений: 21 Регистрация: 11.07.2015	#30 14.07.2015 07:28:41 JeyCi, Ваша добавка пришлась к месту. Стало выглядеть эстетичнее. Спасибо.

Источник

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.

Источник

The Excel MIN function returns the smallest value from a specified range of numeric values

Example: Excel MIN Function

METHOD 1. Excel MIN Function

EXCEL

Result in cell C10 (-7) — returns the smallest numeric value from the selected range.

Result in cell D10 (2) — returns the smallest numeric value from the selected range.

METHOD 2. Excel MIN function using the Excel built-in function library

EXCEL

Formulas tab > Function Library group > More Functions > Statistical > MIN > populate the input box

=MIN(C5:C9)
Note: in this example we are populating an input box with a single range.

METHOD 1. Excel MIN function using VBA

VBA

Sub Excel_MIN_Function()

‘declare a variable
Dim ws As Worksheet

Set ws = Worksheets(«MIN»)

‘apply the Excel MIN function
ws.Range(«C10») = Application.WorksheetFunction.Min(ws.Range(«C5:C9»))
ws.Range(«D10») = Application.WorksheetFunction.Min(ws.Range(«D5:D9»))

End Sub

OBJECTS
Worksheets: The Worksheets object represents all of the worksheets in a workbook, excluding chart sheets.
Range: The Range object is a representation of a single cell or a range of cells in a worksheet.

PREREQUISITES
Worksheet Name: Have a worksheet named MIN.

ADJUSTABLE PARAMETERS
Output Range: Select the output range by changing the Range references («C10») and («D10») in the VBA code to any cell in the worksheet, that doesn’t conflict with the formula.

Usage of the Excel MIN function and formula syntax

EXPLANATION

DESCRIPTION
The Excel MIN function returns the smallest value from a specified range of numeric values.

SYNTAX
=MIN(number1, [number2], …)

ARGUMENT(S)
number1: (Required) A single numeric cell or a range of numeric cells.
number2: (Optional) A single numeric cell or a range of numeric cells.

ADDITIONAL NOTES
Note 1: In Excel 2007 and later the MIN function can accept up to 255 number arguments. In Excel 2003 the MIN function can only accept up to 30 number arguments.

Источник

Finding Smallest and Largest Value with VBA. Using ParamArray to find Minimum Value.

Related Links:

Remove Duplicates in a range, using «Find ‘Smallest’, ‘Largest’, ‘K-th Smallest’ and ‘K-th Largest’ Numbers in a Range, with Excel Functions.

————————————————————————————————

Contents:

Determine smallest value in range

Determine largest value in range

Determine smallest value in each non-blank row and display message mentioning row no. and the value

Determine smallest value in range, highlight and return its address

Determine Minimum Value from a List

Determine Maximum Value from a List

Determine Minimum Value from a Parameter Array

————————————————————————————————

Determine smallest value in range

Sub Smallest()
‘Cells with dates also return a value, and get covered for determining smallest value. Percentages will convert and return numerics.

Dim rng As Range
Dim dblMin As Double

‘Set range from which to determine smallest value
Set rng = Sheet1.Range(«A1:Z100»)

‘Worksheet function MIN returns the smallest value in a range

dblMin = Application.WorksheetFunction.Min(rng)

‘Displays smallest value
MsgBox dblMin

End Sub

Determine largest value in range

Sub Largest()
‘Cells with dates also return a value, and get covered for determining largest value. Percentages will convert and return numerics.

Dim rng As Range
Dim dblMax As Double

‘Set range from which to determine largest value
Set rng = Sheet1.Range(«A1:Z100»)

‘Worksheet function MAX returns the largest value in a range

dblMax = Application.WorksheetFunction.Max(rng)

‘Displays largest value
MsgBox dblMax

End Sub

Determine smallest value in each non-blank row and display message mentioning row no. and the value.

Sub rowSmallest()
‘Cells with dates also return a value, and get covered for determining smallest value. Percentages will convert and return numerics.

Dim rng As Range
Dim currentRow As Long
Dim dblMin As Double
Dim lastRow As Long

‘Determines the last used row number in worksheet
lastRow = Sheet1.UsedRange.Row — 1 + Sheet1.UsedRange.Rows.Count

For currentRow = 1 To lastRow
Set rng = Sheet1.Rows(currentRow)

‘Checks for empty rows provided there are no formulas (including =»» ) or spaces present in any of the cells
If WorksheetFunction.CountA(rng) = 0 Then

MsgBox «Row » & currentRow & » is blank.»

Else

dblMin = Application.WorksheetFunction.Min(rng)
MsgBox «The smallest value in row » & currentRow & » is » & dblMin

End If

Next currentRow

End Sub

Determine smallest value in range, highlight and return its address

Sub Smallest_Value_Highlight_Address()
‘Determines smallest value in range, highlights it and returns its address
‘Cells with dates also return a value, and get covered for determining smallest value. Percentages will convert and return numerics.
‘Determines values from the active worksheet

Dim strData As String
Dim rng As Range
Dim vValue As Variant
Dim rngCol As Range
Dim lngRow As Long

Dim rngAdd As Range

‘Enter desired range in which to find the smallest value

strData = «A1:Z100«

Set rng = Range(strData)

‘Determines smallest value in range
vValue = Application.WorksheetFunction.Min(rng)

For Each rngCol In rng.Columns

‘Determines in case the smallest value exists in a particular column

If Application.WorksheetFunction.CountIf(rngCol, vValue) > 0 Then

‘Returns row number of the smallest value, in the column which has the same

lngRow = Application.WorksheetFunction.Match(vValue, rngCol, 0)

‘Returns cell address of the smallest value

Set rngAdd = rngCol.cells(lngRow, 1)

‘Selects smallest value to highlight with color

rngAdd.Select

With Selection

.Interior.Color = RGB(255, 255, 0)

End With

‘Message displays the searched range, smallest value, and its address

MsgBox «Smallest Value in Range(«»» & strData & «»») is » & vValue & «, in Cell » & rngAdd.Address & «.»

Exit Sub

End If

End Sub

————————————————————————————————————————————————————-
‘ParamArray (Parameter Array): It is not possible to call a procedure with more arguments than the procedure declaration specifies. VBA allows use of optional parameters but you have to know the number of elements in the array ahead of time, when you define the procedure. The ParamArray keyword lets you pass in any number of values. The function receives them as an array. The ParamArray argument makes it possible for a procedure (a function or a subroutine) to accept an arbitrary number of arguments, each of a possibly different type (by using a Variant).

————————————————————————————————————————————————————-

Determine Minimum Value from a List

Function MinInList(ParamArray ArrayList() As Variant)
‘Function will return the minimum value from a list of values

Dim n As Integer
Dim iValue As Variant

‘Set the variable iValue — initialize to the first item or value in list.
iValue = ArrayList(0)

‘Checks each item or value in the list to find the smallest.
‘The UBound function is used with the LBound function to determine the size of an array. Use the LBound function to find the lower limit of an array dimension. Since array subscripts start at 0, the length of a dimension is greater by one than the highest available subscript for that dimension. The largest available subscript for the indicated dimension of an array can be obtained by using the Ubound function.
For n = 0 To UBound(ArrayList)

‘Determines the smallest value.

If ArrayList(n) < iValue Then
iValue = ArrayList(n)
End If

Next n

MinInList = iValue

End Function

Sub SmallestValueInList()
‘Returns minimum value from a List — Calls Function MinInList.

‘Cells(16, 5) contains -308, Range(«B13») contains -400 and Range(«D19») contains the date «2/1/2011». Value returned is -400, being the smallest.
MsgBox MinInList(1, -5, 3, -8, -9, hello, 10 * -1, cells(16, 5), Range(«B13»), Range(«D19»))

‘Range(«D19») contains the date «2/1/2011», Range(«H8») contains the date «3/5/2010» and Range(«I10») contains the date «3/5/2009». Date returned is «3/5/2009», being the smallest.
MsgBox MinInList(Range(«D19»), Range(«H8»), Range(«I10»))

End Sub

Determine Maximum Value from a List

Function MaxInList(ParamArray ArrayList() As Variant)
‘Function will return the maximum value from a list of values

Dim n As Integer
Dim iValue As Variant

‘Set the variable iValue — initialize to the first item or value in list.
iValue = ArrayList(0)

‘Checks each item or value in the list to find the largest.
For n = 0 To UBound(ArrayList)

‘Determines the largest value.

If ArrayList(n) > iValue Then
iValue = ArrayList(n)

Next n

MaxInList = iValue

End Function

Sub LargestValueInList()
‘Returns maximum value from a List- Calls Function MaxInList.

‘Range(«K7») contains 3000. Value returned and displayed in message box is 3000, being the largest.
MsgBox MaxInList(1, -5, 3, -8, -9, hello, 10 * -1, Range(«K7»))

‘Range(«D19») contains the date «2/1/2011», Range(«H8») contains the date «3/5/2010» and Range(«I10») contains the date «3/5/2009». Date returned is «2/1/2011», being the largest.
MsgBox MaxInList(Range(«D19»), Range(«H8»), Range(«I10»))

Determine Minimum Value from a Parameter Array (also works for nested array or a multiple column range)

Function minimum(ParamArray Values() As Variant)
‘Returns minimum value from a Parameter Array (also works for nested array or a multiple column range).

Dim Item As Variant
Dim Part As Variant

For Each Item In Values

‘Checks if an item in the array of Values is itself an array (viz. nested array) and determines minimum value therein
If IsArray(Item) Then

For Each Part In Item

minimum = minimum(Part, minimum)

‘If an item in the array of Values is not an array

If Not IsEmpty(minimum) Then

If Item < minimum And Not IsEmpty(Item) Then

minimum = Item

End If

Else

minimum = Item

End If

End Function

Sub SmallestValue()
‘Returns minimum value from a Parameter Array (also works for nested array or a multiple column range).

‘Returns -25.
MsgBox minimum(Array(11, 20, -16), -14, hello, -18.5, Array(1, Array(1 * -25, -21, -1), -11))

‘Returns 11.
MsgBox minimum(16.5, 11, 20)

‘Returns -7700, smallest value in range which is in cell «B27».
MsgBox minimum(Range(«A1:Z100»))

‘Cells(16, 5) contains -308, Range(«B13») contains -400 and Range(«D19») contains the date «2/1/2011». Value returned is -400, being the smallest.
MsgBox minimum(1, -5, 3, -8, -9, hello, 10 * -1, cells(16, 5), Range(«B13»), Range(«D19»))

‘Range(«D19») contains the date «2/1/2011», Range(«H8») contains the date «3/5/2010» and Range(«I10») contains the date «3/5/2009». Date returned is «3/5/2009», being the smallest.
MsgBox minimum(Range(«D19»), Range(«H8»), Range(«I10»))

Источник

Asked
7 years, 9 months ago

Viewed
329 times

10.00   b1
11.00   b2
22.00   b3
2.00    b1
323.00  b2
1.00    b3
423.00  b1
32.00   b2
42.00   b3
43.00   b1
522.00  b2
53.00   b3
22.00   b1
344.00  b2
33.00   b3
23445.00    b1
323.00  b2
4.00    b3

How can I find the minimum value of column1 where value of column2 = b2?

excel
vba

asked Jul 15, 2015 at 5:33

Perhaps you could sort them ascending?

Jul 15, 2015 at 5:37
you can find the answer to this in probably every tutorial and on many many other sites through a web search.

Jul 15, 2015 at 5:38

1 Answer

Here, I got one for you. It is an excel formula.

=MIN(IF(B1:B100="b2",A1:A100))

answered Jul 15, 2015 at 6:50

R.KatnaanR.Katnaan

2,4764 gold badges23 silver badges35 bronze badges

The Overflow Blog
Featured on Meta

Hot Network Questions

How to remedy roof overhang not level
What visa covers me for remote working in the US whilst on holiday?
Parse a CSV file
Can I develop Windows, macOS, and Linux software or a game on one Linux distribution?
How is Hilbert space constructed in interacting theory?
Do I need 88 keys to produce film soundtracks?
Do I know all the abilities of a Dominated creature?
Draw a rectangle with partly invisible edges, only corners
Why doesn’t read permission on directories reveal inode numbers?
Getting an «Incorrect syntax near ‘(‘ » error message when using the standard create table using a select in SQL Server
How can one transform a neutral lookup table texture for color blindness?
Does Ohm’s law always apply at any instantaneous point in time?
Why are the back of the wings of some aerobatic planes swept forward?
Horror novel involving teenagers killed at a beach party for their part in another’s (accidental) death
Gödel encoding — Part I
How much louder was a Napoleonic era cannon than a musket?
Deal or No Deal, Puzzling Edition
Is -ist a gender-neutral ending?
Derivative without extrema is monotone
How should I water and feed lilac bushes?
Did Hitler say that «private enterprise cannot be maintained in a democracy»?
What is the difference between elementary and non-elementary proofs of the Prime Number Theorem?
How to tell what configuration a transistor has in a complicated circuit
«Why» do animals excrete excess nitrogen instead of recycling it?