Добрый день столкнулся с таким заданием, есть несколько листов на них есть столбец с наименованием, причем в каждом из листов они немного отличаются, т.е. не везде есть все, надо как-то найти самое наименьшее значение из этих листов и внести его в итоговый с заливкой, которая задается для каждого листа отдельно. Скажите такое вообще возможно штатными формулами и правилами сделать, или надо макрос какой писать.
Добрый день столкнулся с таким заданием, есть несколько листов на них есть столбец с наименованием, причем в каждом из листов они немного отличаются, т.е. не везде есть все, надо как-то найти самое наименьшее значение из этих листов и внести его в итоговый с заливкой, которая задается для каждого листа отдельно. Скажите такое вообще возможно штатными формулами и правилами сделать, или надо макрос какой писать.mouravy
надо как-то найти самое наименьшее значение из этих листов и внести его в итоговый с заливкой, которая задается для каждого листа отдельно.
Круто! А что же Вы не показали, как это должно выглядеть? Из примера наименьшее значение имеет Апельсин=Красная заливка=2, что должно быть на листе Итого (с учетом того, что там три, или четыре столбца, должны быть заполнены какими то данными)? Догадайся сам? А может быть вам консолидация нужна, но там в цвета листов не окрашивается, увы.
надо как-то найти самое наименьшее значение из этих листов и внести его в итоговый с заливкой, которая задается для каждого листа отдельно.
Круто! А что же Вы не показали, как это должно выглядеть? Из примера наименьшее значение имеет Апельсин=Красная заливка=2, что должно быть на листе Итого (с учетом того, что там три, или четыре столбца, должны быть заполнены какими то данными)? Догадайся сам? А может быть вам консолидация нужна, но там в цвета листов не окрашивается, увы.gling
ЯД-41001506838083
Сообщение отредактировал gling - Пятница, 16.12.2016, 20:44
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
[/vba]
Добавлено в обработку: - раскраска ярлыков листов - динамическое количество листов - динамическое количество строк для каждого листа - запуск макроса не зависит от того какой лист активен
Ограничения: - привязана к формату листов, т.е. 1-я строка - шапка, количество и формат содержимого колонок строго оговорено как в задании (иначе, в случае не корректных данных ВБА может очень удивиться) - не допускаются пустые названия в 1-ой колонке в середине таблиц (это будет распознано как конец данных на данном листе - итоговый результат будет всегда на последнем листе, лист предварительно не очищается
Нарисовал... [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, 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
[/vba]
Добавлено в обработку: - раскраска ярлыков листов - динамическое количество листов - динамическое количество строк для каждого листа - запуск макроса не зависит от того какой лист активен
Ограничения: - привязана к формату листов, т.е. 1-я строка - шапка, количество и формат содержимого колонок строго оговорено как в задании (иначе, в случае не корректных данных ВБА может очень удивиться) - не допускаются пустые названия в 1-ой колонке в середине таблиц (это будет распознано как конец данных на данном листе - итоговый результат будет всегда на последнем листе, лист предварительно не очищаетсяdim34rus
dim34rus, Спасибо большое, то что нужно. Только возник вопрос, а если столбцов больше 3 для сравнения, до 300 может доходить, где в макросе это править?
dim34rus, Спасибо большое, то что нужно. Только возник вопрос, а если столбцов больше 3 для сравнения, до 300 может доходить, где в макросе это править?mouravy
[/vba] нужно организовать через цикл. При этом[vba]
Код
mas(k, 5) = i
[/vba] будет выглядеть как [vba]
Код
mas(k,<желаемое кол-во колонок>+2) = i
[/vba] 3.В цикле сортировки [vba]
Код
For j = 1 To 5
[/vba] поменять 5 на <желаемое кол-во колонок>+2 4.И в блоке "Выводим" поменять два цикла [vba]
Код
For j = 1 To 4
[/vba] и [vba]
Код
For j = 2 To 4
[/vba] "4" поменять на <желаемое кол-во колонок>+1
В принципе <желаемое кол-во колонок> можно сделать переменной, но тогда для ее определения, необходимо будет: сначала пробежаться по всем листам и посчитать количество колонок на каждом, и из этого всего выбрать бОльшее значение. это и будет <желаемое кол-во колонок> в динамическом выражении
[/vba] нужно организовать через цикл. При этом[vba]
Код
mas(k, 5) = i
[/vba] будет выглядеть как [vba]
Код
mas(k,<желаемое кол-во колонок>+2) = i
[/vba] 3.В цикле сортировки [vba]
Код
For j = 1 To 5
[/vba] поменять 5 на <желаемое кол-во колонок>+2 4.И в блоке "Выводим" поменять два цикла [vba]
Код
For j = 1 To 4
[/vba] и [vba]
Код
For j = 2 To 4
[/vba] "4" поменять на <желаемое кол-во колонок>+1
В принципе <желаемое кол-во колонок> можно сделать переменной, но тогда для ее определения, необходимо будет: сначала пробежаться по всем листам и посчитать количество колонок на каждом, и из этого всего выбрать бОльшее значение. это и будет <желаемое кол-во колонок> в динамическом выражении dim34rus
Извращение - это писать формулы в Word'овских таблицах. ЯД 410014340958327
Сообщение отредактировал dim34rus - Понедельник, 19.12.2016, 15:49
for kk=1 to <желаемое количество колонок> + 1 mas(k, kk) = ActiveWorkbook.Sheets.Item(i).Cells(j, kk).Value Next
[/vba]
Зыж в связи с изменениями уже так часто встречается <желаемое количество колонок>, что я бы для этого уже сделал бы какую либо переменную и инициализировал бы ее вначале
Блин все время забываю написать, что вся эта кухня работает, когда на разных листах наименования синхронизированы, т.е. если на одном листе будет написано "Банан", а на другом "Бонан" или "БАНАН", то все это будут разные значения, хотя с большими буквами легким движением руки еще можно справиться.
Да именно это удаляем и пишем [vba]
Код
for kk=1 to <желаемое количество колонок> + 1 mas(k, kk) = ActiveWorkbook.Sheets.Item(i).Cells(j, kk).Value Next
[/vba]
Зыж в связи с изменениями уже так часто встречается <желаемое количество колонок>, что я бы для этого уже сделал бы какую либо переменную и инициализировал бы ее вначале
Блин все время забываю написать, что вся эта кухня работает, когда на разных листах наименования синхронизированы, т.е. если на одном листе будет написано "Банан", а на другом "Бонан" или "БАНАН", то все это будут разные значения, хотя с большими буквами легким движением руки еще можно справиться.dim34rus
Извращение - это писать формулы в Word'овских таблицах. ЯД 410014340958327
Сообщение отредактировал dim34rus - Понедельник, 19.12.2016, 17:18
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 With End Sub
[/vba]
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 With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
