Выбор наименьшего значения из листов

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Выбор наименьшего значения из листов (Формулы/Formulas)

mouravy

Дата: Пятница, 16.12.2016, 16:56 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

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

К сообщению приложен файл: ___.xlsx (12.1 Kb)

Ответить

gling

Дата: Пятница, 16.12.2016, 20:24 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2643

Репутация: 739 ±

Замечаний: 0% ±

2010

Цитата mouravy, 16.12.2016 в 16:56, в сообщении № 1 ( писал(а)):

надо как-то найти самое наименьшее значение из этих листов и внести его в итоговый с заливкой, которая задается для каждого листа отдельно.

Круто! А что же Вы не показали, как это должно выглядеть? Из примера наименьшее значение имеет Апельсин=Красная заливка=2, что должно быть на листе Итого (с учетом того, что там три, или четыре столбца, должны быть заполнены какими то данными)? Догадайся сам? А может быть вам консолидация нужна, но там в цвета листов не окрашивается, увы.

ЯД-41001506838083

Сообщение отредактировал gling - Пятница, 16.12.2016, 20:44

Ответить

dim34rus Дата: Пятница, 16.12.2016, 20:31 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 66

Репутация: 10 ±

Замечаний: 0% ±

Excel 2007 - 2013

Нарисовал...

Sub optimal() Dim mas() As Variant Dim List As Integer Dim Colors() As Double List = ActiveWorkbook.Sheets.Count ReDim Colors(List - 1) Size = 0 For i = 1 To List - 1 Size = Size + ActiveWorkbook.Sheets.Item(i).Cells.SpecialCells(xlLastCell).Row - 1 Next ReDim mas(Size, 5) k = 1 For i = 1 To List - 1 j = 2 While ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value <> "" mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value mas(k, 2) = ActiveWorkbook.Sheets.Item(i).Cells(j, 2).Value mas(k, 3) = ActiveWorkbook.Sheets.Item(i).Cells(j, 3).Value mas(k, 4) = ActiveWorkbook.Sheets.Item(i).Cells(j, 4).Value mas(k, 5) = i k = k + 1 j = j + 1 Wend Colors(i) = ActiveWorkbook.Sheets.Item(i).Cells(1, 4).Interior.Color 'Раскрасим ярлык листа With ActiveWorkbook.Sheets.Item(i).Tab .Color = Colors(i) .TintAndShade = 0 End With Next 'сортировка по возрастанию For i = 1 To Size - 1 For k = 1 To Size - i If StrComp(mas(k, 1), mas(k + 1, 1), 1) > 0 Then For j = 1 To 5 Buf = mas(k, j) mas(k, j) = mas(k + 1, j) mas(k + 1, j) = Buf Next End If Next Next 'выводим With ActiveWorkbook.Sheets.Item(List) k = 2 For i = 1 To Size If mas(i, 1) <> "" Then If .Cells(k, 1).Value = "" Then For j = 1 To 4 .Cells(k, j).Value = mas(i, j) If j > 1 Then 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 5)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else If .Cells(k, 1).Value = mas(i, 1) Then For j = 2 To 4 If .Cells(k, j).Value > mas(i, j) Then .Cells(k, j).Value = mas(i, j) 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 5)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else k = k + 1 End If End If End If Next End With End Sub

Добавлено в обработку:
- раскраска ярлыков листов
- динамическое количество листов
- динамическое количество строк для каждого листа
- запуск макроса не зависит от того какой лист активен

Ограничения:
- привязана к формату листов, т.е. 1-я строка - шапка, количество и формат содержимого колонок строго оговорено как в задании (иначе, в случае не корректных данных ВБА может очень удивиться)
- не допускаются пустые названия в 1-ой колонке в середине таблиц (это будет распознано как конец данных на данном листе
- итоговый результат будет всегда на последнем листе, лист предварительно не очищается

Нарисовал...

К сообщению приложен файл: 1617192.xlsm (23.2 Kb)

Извращение - это писать формулы в Word'овских таблицах.
ЯД 410014340958327

Сообщение отредактировал dim34rus - Суббота, 17.12.2016, 00:28

Ответить

СообщениеНарисовал...
[vba]

[/vba]

Добавлено в обработку:
- раскраска ярлыков листов
- динамическое количество листов
- динамическое количество строк для каждого листа
- запуск макроса не зависит от того какой лист активен

Ограничения:
- привязана к формату листов, т.е. 1-я строка - шапка, количество и формат содержимого колонок строго оговорено как в задании (иначе, в случае не корректных данных ВБА может очень удивиться)
- не допускаются пустые названия в 1-ой колонке в середине таблиц (это будет распознано как конец данных на данном листе
- итоговый результат будет всегда на последнем листе, лист предварительно не очищается

Автор - dim34rus
Дата добавления - 16.12.2016 в 20:31

mouravy

Дата: Понедельник, 19.12.2016, 14:02 | Сообщение № 4

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

dim34rus, Спасибо большое, то что нужно. Только возник вопрос, а если столбцов больше 3 для сравнения, до 300 может доходить, где в макросе это править?

Ответить

dim34rus Дата: Понедельник, 19.12.2016, 15:43 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 66

Репутация: 10 ±

Замечаний: 0% ±

Excel 2007 - 2013

Цитата mouravy, 19.12.2016 в 14:02, в сообщении № 4 ( писал(а)):

где в макросе это править

Это надо сделать в нескольких местах.
1. Размер массива

Redim mas(Size,5)

Поменять на

Redim mas(Size,<желаемое кол-во колонок>+2)

2. Чтение данных в массив

mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value

нужно организовать через цикл. При этом

mas(k, 5) = i

будет выглядеть как

mas(k,<желаемое кол-во колонок>+2) = i

3.В цикле сортировки

For j = 1 To 5

поменять 5 на <желаемое кол-во колонок>+2
4.И в блоке "Выводим" поменять два цикла

For j = 1 To 4

For j = 2 To 4

"4" поменять на <желаемое кол-во колонок>+1

В принципе <желаемое кол-во колонок> можно сделать переменной, но тогда для ее определения, необходимо будет:
сначала пробежаться по всем листам и посчитать количество колонок на каждом, и из этого всего выбрать бОльшее значение. это и будет <желаемое кол-во колонок> в динамическом выражении

Извращение - это писать формулы в Word'овских таблицах.
ЯД 410014340958327

Сообщение отредактировал dim34rus - Понедельник, 19.12.2016, 15:49

Ответить

mouravy Дата: Понедельник, 19.12.2016, 16:17 | Сообщение № 6

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

2. Чтение данных в массив

mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value

нужно организовать через цикл.

Понимаю что надоел, но ни в зкб ногой в макросах, как цикл выглядеть должен?

и как я понимаю
это удаляю

mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value mas(k, 2) = ActiveWorkbook.Sheets.Item(i).Cells(j, 2).Value mas(k, 3) = ActiveWorkbook.Sheets.Item(i).Cells(j, 3).Value mas(k, 4) = ActiveWorkbook.Sheets.Item(i).Cells(j, 4).Value

Сообщение отредактировал mouravy - Понедельник, 19.12.2016, 19:09

Ответить

dim34rus Дата: Понедельник, 19.12.2016, 17:05 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 66

Репутация: 10 ±

Замечаний: 0% ±

Excel 2007 - 2013

Да именно это удаляем и пишем

for kk=1 to <желаемое количество колонок> + 1 mas(k, kk) = ActiveWorkbook.Sheets.Item(i).Cells(j, kk).Value Next

Зыж в связи с изменениями уже так часто встречается <желаемое количество колонок>, что я бы для этого уже сделал бы какую либо переменную и инициализировал бы ее вначале

Блин все время забываю написать, что вся эта кухня работает, когда на разных листах наименования синхронизированы, т.е. если на одном листе будет написано "Банан", а на другом "Бонан" или "БАНАН", то все это будут разные значения, хотя с большими буквами легким движением руки еще можно справиться.

Извращение - это писать формулы в Word'овских таблицах.
ЯД 410014340958327

Сообщение отредактировал dim34rus - Понедельник, 19.12.2016, 17:18

Ответить

mouravy Дата: Понедельник, 19.12.2016, 19:08 | Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

dim34rus, спасибо большое за помощь в итоге получился такой макрос и он работает.

Sub optimal() Dim mas() As Variant Dim List As Integer Dim Colors() As Double List = ActiveWorkbook.Sheets.Count ReDim Colors(List - 1) Size = 0 For i = 1 To List - 1 Size = Size + ActiveWorkbook.Sheets.Item(i).Cells.SpecialCells(xlLastCell).Row - 1 Next ReDim mas(Size, 303) k = 1 For i = 1 To List - 1 j = 2 While ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value <> "" For kk = 1 To 302 mas(k, kk) = ActiveWorkbook.Sheets.Item(i).Cells(j, kk).Value Next mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value mas(k, 2) = ActiveWorkbook.Sheets.Item(i).Cells(j, 2).Value mas(k, 3) = ActiveWorkbook.Sheets.Item(i).Cells(j, 3).Value mas(k, 4) = ActiveWorkbook.Sheets.Item(i).Cells(j, 4).Value mas(k, 303) = i k = k + 1 j = j + 1 Wend Colors(i) = ActiveWorkbook.Sheets.Item(i).Cells(1, 4).Interior.Color 'Раскрасим ярлык листа With ActiveWorkbook.Sheets.Item(i).Tab .Color = Colors(i) .TintAndShade = 0 End With Next 'сортировка по возрастанию For i = 1 To Size - 1 For k = 1 To Size - i If StrComp(mas(k, 1), mas(k + 1, 1), 1) > 0 Then For j = 1 To 303 Buf = mas(k, j) mas(k, j) = mas(k + 1, j) mas(k + 1, j) = Buf Next End If Next Next 'выводим With ActiveWorkbook.Sheets.Item(List) k = 2 For i = 1 To Size If mas(i, 1) <> "" Then If .Cells(k, 1).Value = "" Then For j = 1 To 302 .Cells(k, j).Value = mas(i, j) If j > 1 Then 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 303)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else If .Cells(k, 1).Value = mas(i, 1) Then For j = 2 To 302 If .Cells(k, j).Value > mas(i, j) Then .Cells(k, j).Value = mas(i, j) 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 303)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else k = k + 1 End If End If End If Next End With End Sub

dim34rus, спасибо большое за помощь в итоге получился такой макрос и он работает.

Sub optimal() Dim mas() As Variant Dim List As Integer Dim Colors() As Double List = ActiveWorkbook.Sheets.Count ReDim Colors(List - 1) Size = 0 For i = 1 To List - 1 Size = Size + ActiveWorkbook.Sheets.Item(i).Cells.SpecialCells(xlLastCell).Row - 1 Next ReDim mas(Size, 303) k = 1 For i = 1 To List - 1 j = 2 While ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value <> "" For kk = 1 To 302 mas(k, kk) = ActiveWorkbook.Sheets.Item(i).Cells(j, kk).Value Next mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value mas(k, 2) = ActiveWorkbook.Sheets.Item(i).Cells(j, 2).Value mas(k, 3) = ActiveWorkbook.Sheets.Item(i).Cells(j, 3).Value mas(k, 4) = ActiveWorkbook.Sheets.Item(i).Cells(j, 4).Value mas(k, 303) = i k = k + 1 j = j + 1 Wend Colors(i) = ActiveWorkbook.Sheets.Item(i).Cells(1, 4).Interior.Color 'Раскрасим ярлык листа With ActiveWorkbook.Sheets.Item(i).Tab .Color = Colors(i) .TintAndShade = 0 End With Next 'сортировка по возрастанию For i = 1 To Size - 1 For k = 1 To Size - i If StrComp(mas(k, 1), mas(k + 1, 1), 1) > 0 Then For j = 1 To 303 Buf = mas(k, j) mas(k, j) = mas(k + 1, j) mas(k + 1, j) = Buf Next End If Next Next 'выводим With ActiveWorkbook.Sheets.Item(List) k = 2 For i = 1 To Size If mas(i, 1) <> "" Then If .Cells(k, 1).Value = "" Then For j = 1 To 302 .Cells(k, j).Value = mas(i, j) If j > 1 Then 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 303)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else If .Cells(k, 1).Value = mas(i, 1) Then For j = 2 To 302 If .Cells(k, j).Value > mas(i, j) Then .Cells(k, j).Value = mas(i, j) 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 303)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else k = k + 1 End If End If End If Next End With End Sub

mouravy

Ответить

Сообщениеdim34rus, спасибо большое за помощь в итоге получился такой макрос и он работает.

[vba]

Sub optimal() Dim mas() As Variant Dim List As Integer Dim Colors() As Double List = ActiveWorkbook.Sheets.Count ReDim Colors(List - 1) Size = 0 For i = 1 To List - 1 Size = Size + ActiveWorkbook.Sheets.Item(i).Cells.SpecialCells(xlLastCell).Row - 1 Next ReDim mas(Size, 303) k = 1 For i = 1 To List - 1 j = 2 While ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value <> "" For kk = 1 To 302 mas(k, kk) = ActiveWorkbook.Sheets.Item(i).Cells(j, kk).Value Next mas(k, 1) = ActiveWorkbook.Sheets.Item(i).Cells(j, 1).Value mas(k, 2) = ActiveWorkbook.Sheets.Item(i).Cells(j, 2).Value mas(k, 3) = ActiveWorkbook.Sheets.Item(i).Cells(j, 3).Value mas(k, 4) = ActiveWorkbook.Sheets.Item(i).Cells(j, 4).Value mas(k, 303) = i k = k + 1 j = j + 1 Wend Colors(i) = ActiveWorkbook.Sheets.Item(i).Cells(1, 4).Interior.Color 'Раскрасим ярлык листа With ActiveWorkbook.Sheets.Item(i).Tab .Color = Colors(i) .TintAndShade = 0 End With Next 'сортировка по возрастанию For i = 1 To Size - 1 For k = 1 To Size - i If StrComp(mas(k, 1), mas(k + 1, 1), 1) > 0 Then For j = 1 To 303 Buf = mas(k, j) mas(k, j) = mas(k + 1, j) mas(k + 1, j) = Buf Next End If Next Next 'выводим With ActiveWorkbook.Sheets.Item(List) k = 2 For i = 1 To Size If mas(i, 1) <> "" Then If .Cells(k, 1).Value = "" Then For j = 1 To 302 .Cells(k, j).Value = mas(i, j) If j > 1 Then 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 303)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else If .Cells(k, 1).Value = mas(i, 1) Then For j = 2 To 302 If .Cells(k, j).Value > mas(i, j) Then .Cells(k, j).Value = mas(i, j) 'раскраска .Cells(k, j).Interior.Pattern = xlSolid .Cells(k, j).Interior.PatternColorIndex = xlAutomatic .Cells(k, j).Interior.Color = Colors(mas(i, 303)) .Cells(k, j).Interior.TintAndShade = 0 .Cells(k, j).Interior.PatternTintAndShade = 0 End If Next Else k = k + 1 End If End If End If Next End WithEnd Sub

[/vba]

Автор - mouravy
Дата добавления - 19.12.2016 в 19:08

Выбор наименьшего значения из листов (Формулы/Formulas)

Страница 1 из 1
1