Vba как найти минимальное число

You can use the following basic syntax to calculate the minimum value in a range using VBA:

Sub MinValue()
    Range("D2") = WorksheetFunction.Min(Range("B2:B11"))
End Sub

This particular example calculates the minimum value in the range B2:B11 and assigns the result to cell D2.

If you would instead like to display the minimum value in a message box, you can use the following syntax:

Sub MinValue()
    'Create variable to store min value
    Dim minValue As Single
    
    'Calculate min value in range
    minValue = WorksheetFunction.Min(Range("B2:B11"))
    
    'Display the result
    MsgBox "Min Value in Range: " & minValue 
End Sub

The following examples shows how to use each of these methods in practice with the following dataset in Excel that contains information about various basketball players:

Related: How to Find Max Value in Range Using VBA

Example 1: Calculate Minimum Value of Range Using VBA and Display Results in Cell

Suppose we would like to calculate the minimum value in the points column and output the results in a specific cell.

We can create the following macro to do so:

Sub MinValue()
    Range("D2") = WorksheetFunction.Min(Range("B2:B11"))
End Sub

When we run this macro, we receive the following output:

Notice that cell D2 contains a value of 10.

This tells us that the minimum value in the points column is 10.

Example 2: Calculate Minimum Value of Range Using VBA and Display Results in Message Box

Suppose we would instead like to calculate the minimum value in the points column and output the results in a message box.

We can create the following macro to do so:

Sub MinValue()
    'Create variable to store min value
    Dim minValue As Single
    
    'Calculate min value in range
    minValue = WorksheetFunction.Min(Range("B2:B11"))
    
    'Display the result
    MsgBox "Min Value in Range: " & minValue 
End Sub

When we run this macro, we receive the following output:

The message box tells us that the minimum value in the range B2:B11 is 10.

Note that in this example we calculated the minimum value in the range B2:B11.

However, if you’d like to instead calculate the minimum value in an entire column you could type B:B instead.

This will calculate the minimum value in all of column B.

Additional Resources

The following tutorials explain how to perform other common tasks in VBA:

VBA: How to Calculate Average Value of Range
VBA: How to Count Number of Rows in Range
VBA: How to Sum Values in Range

Источник

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.9k46 gold badges146 silver badges222 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 badge30 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.2k7 gold badges112 silver badges151 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,6201 gold badge35 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.

Источник

Поиск минимального элемента массива на 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 текст не удается выровнять по ширине: по левому краю выравнивает, по правому — тоже, а вот по ширине — ни в какую. Еще хуже обстоят дела, если вы захотите увеличить размер шрифта: выравнивание текста окончательно откажется работать. Разбираемся в причинах и ищем способ, как это исправить.

Скопированный в Word текст выходит за границы страницы

Скопировав текст в Word с Интернет-сайта или другого текстового документа, часто приходится сталкиваться с ситуацией, когда он выходит за границы страницы. Ситуация осложняется тем, что маркер » Отступ справа » на горизонтальной линейке, с помощью которого можно было бы все исправить, отсутствует. Как быть? Выход есть и он очень простой. Для этого необходимо выполнить несколько действий.

Источник

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

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

Сообщений: 3387
Регистрация: 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

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

Сообщений: 3387
Регистрация: 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

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

Сообщений: 3387
Регистрация: 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

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

Сообщений: 14849
Регистрация: 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

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

Юрий М Модератор Сообщений: 60750 Регистрация: 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

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

Сообщений: 14849
Регистрация: 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) и у меня теперь все работает, как я и просил.
Считаю, что задача решена. Большое вам всем спасибо.
ТС (Егор М.)

Юрий М

Модератор

Сообщений: 60750
Регистрация: 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

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

Сообщений: 14849
Регистрация: 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

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

Сообщений: 3387
Регистрация: 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, Ваша добавка пришлась к месту. Стало выглядеть эстетичнее. Спасибо.

Источник

Example 1: Calculate Minimum Value of Range Using VBA and Display Results in Cell

Example 2: Calculate Minimum Value of Range Using VBA and Display Results in Message Box

Additional Resources

Поиск минимального элемента массива на VBA

Популярные сообщения из этого блога

Куда пропал редактор формул Microsoft Equation?

Что делать, если копируемый из Интернета текст не выравнивается по ширине

Скопированный в Word текст выходит за границы страницы

Не пропустите также: