Подскажите, как изменить макрос, представленный в этой теме, чтобы он собирал свод данных исходя из цвета ярлычка листа. К примеру, в представленном в той теме примере имеется 2 цвета: бесцветный и лиловый. Нужно, чтобы макрос сделал 2 свода таблиц для каждого цвета.
Добрый день, программисты и обычные пользователи!
Подскажите, как изменить макрос, представленный в этой теме, чтобы он собирал свод данных исходя из цвета ярлычка листа. К примеру, в представленном в той теме примере имеется 2 цвета: бесцветный и лиловый. Нужно, чтобы макрос сделал 2 свода таблиц для каждого цвета.Мурад
Не сильно видоизменяя макрос, просто добавим условие на проверку цвета ярлыка. Ну и шуточку еще небольшую [vba]
Код
Sub www() Dim ws As Worksheet, l& With Sheets("Svod") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = .Name Then If ws.Tab.Color = .Tab.Color Then l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 ws.UsedRange.Offset(1).Copy .Range("a" & l) End If End If Next End With With Sheets("Svоd") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = .Name Then If ws.Tab.Color = .Tab.Color Then l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 ws.UsedRange.Offset(1).Copy .Range("a" & l) End If End If Next End With End Sub
[/vba]
Не сильно видоизменяя макрос, просто добавим условие на проверку цвета ярлыка. Ну и шуточку еще небольшую [vba]
Код
Sub www() Dim ws As Worksheet, l& With Sheets("Svod") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = .Name Then If ws.Tab.Color = .Tab.Color Then l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 ws.UsedRange.Offset(1).Copy .Range("a" & l) End If End If Next End With With Sheets("Svоd") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = .Name Then If ws.Tab.Color = .Tab.Color Then l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 ws.UsedRange.Offset(1).Copy .Range("a" & l) End If End If Next End With End Sub
Просто у меня данные в книге окрашены в 3 разные цвета, начинаются числовые строки с ячейки B4. Я создал 3 листа с названиями свод-1, свод-2, свод-3. сделал 3 кнопки с 3 макросами для каждого листа
Просто у меня данные в книге окрашены в 3 разные цвета, начинаются числовые строки с ячейки B4. Я создал 3 листа с названиями свод-1, свод-2, свод-3. сделал 3 кнопки с 3 макросами для каждого листаМурад
Еще заметил, что надо добавить условие в макросе, чтоб для листа свод-1 он не хватал данные с соседних сводных листов - свод-2 и свод-3. Я поправил код на: [vba]
Код
If Not ws.Name = "свод" & "*" Then
[/vba] но макрос все равно хватает данные со всех листов
Еще заметил, что надо добавить условие в макросе, чтоб для листа свод-1 он не хватал данные с соседних сводных листов - свод-2 и свод-3. Я поправил код на: [vba]
Код
If Not ws.Name = "свод" & "*" Then
[/vba] но макрос все равно хватает данные со всех листовМурад
Держите один макрос на все 3 листа сразу. Если захотите поделить по отдельности, то по With делите [vba]
Код
Sub Путевые_Листы_1() Dim ws As Worksheet, l& With Sheets("свод-1") .UsedRange.Offset(4).ClearContents For Each ws In Worksheets If Not UCase(Left(ws.Name, 4)) = "СВОД" Then If ws.Tab.Color = .Tab.Color Then r1_ = .Range("B" & Rows.Count).End(3).Row + 1 ws.UsedRange.Offset(3).Copy .Range("A" & r1_) End If End If Next End With With Sheets("свод-2") .UsedRange.Offset(4).ClearContents For Each ws In Worksheets If Not UCase(Left(ws.Name, 4)) = "СВОД" Then If ws.Tab.Color = .Tab.Color Then r1_ = .Range("B" & Rows.Count).End(3).Row + 1 ws.UsedRange.Offset(3).Copy .Range("A" & r1_) End If End If Next End With With Sheets("свод-3") .UsedRange.Offset(4).ClearContents For Each ws In Worksheets If Not UCase(Left(ws.Name, 4)) = "СВОД" Then If ws.Tab.Color = .Tab.Color Then r1_ = .Range("B" & Rows.Count).End(3).Row + 1 ws.UsedRange.Offset(3).Copy .Range("A" & r1_) End If End If Next End With End Sub
[/vba]
Мурад, в моем макросе из второго поста два кажущихся одинаковими блока на самом деле не одинаковы, там тоже
Держите один макрос на все 3 листа сразу. Если захотите поделить по отдельности, то по With делите [vba]
Код
Sub Путевые_Листы_1() Dim ws As Worksheet, l& With Sheets("свод-1") .UsedRange.Offset(4).ClearContents For Each ws In Worksheets If Not UCase(Left(ws.Name, 4)) = "СВОД" Then If ws.Tab.Color = .Tab.Color Then r1_ = .Range("B" & Rows.Count).End(3).Row + 1 ws.UsedRange.Offset(3).Copy .Range("A" & r1_) End If End If Next End With With Sheets("свод-2") .UsedRange.Offset(4).ClearContents For Each ws In Worksheets If Not UCase(Left(ws.Name, 4)) = "СВОД" Then If ws.Tab.Color = .Tab.Color Then r1_ = .Range("B" & Rows.Count).End(3).Row + 1 ws.UsedRange.Offset(3).Copy .Range("A" & r1_) End If End If Next End With With Sheets("свод-3") .UsedRange.Offset(4).ClearContents For Each ws In Worksheets If Not UCase(Left(ws.Name, 4)) = "СВОД" Then If ws.Tab.Color = .Tab.Color Then r1_ = .Range("B" & Rows.Count).End(3).Row + 1 ws.UsedRange.Offset(3).Copy .Range("A" & r1_) End If End If Next End With End Sub
Александр, все работает для данного примера! Спасибо. Далее я буквально переношу этот макрос в книгу с исходными данными, где у меня 25 зеленых листов, 7 оранжевых и 2 лиловых. Запускаю, и макрос начинает переносить данные на листы свод-1, свод-2, свод-3, начиная с ячейки A4, вместо B4. В примере ведь все работает, а в другом файле с другим числом листов уже не работает Может, нужно изменить код [vba]
Код
ws.UsedRange.Offset(3).Copy .Range("A" & r1_)
[/vba] на другой? [vba]
Код
ws.UsedRange.Offset(3).Copy .Range("B" & r1_)
[/vba]
В исходном файле абсолютно такая же шапка, как в файле "example", начинается таблица со столбца В. ничего не менял для примера
Александр, все работает для данного примера! Спасибо. Далее я буквально переношу этот макрос в книгу с исходными данными, где у меня 25 зеленых листов, 7 оранжевых и 2 лиловых. Запускаю, и макрос начинает переносить данные на листы свод-1, свод-2, свод-3, начиная с ячейки A4, вместо B4. В примере ведь все работает, а в другом файле с другим числом листов уже не работает Может, нужно изменить код [vba]
Код
ws.UsedRange.Offset(3).Copy .Range("A" & r1_)
[/vba] на другой? [vba]
Код
ws.UsedRange.Offset(3).Copy .Range("B" & r1_)
[/vba]
В исходном файле абсолютно такая же шапка, как в файле "example", начинается таблица со столбца В. ничего не менял для примераМурад
Сообщение отредактировал Мурад - Вторник, 03.10.2017, 15:42
А макрос и у меня переносил со столбца А. В Вашем примере в А ничего нет, поэтому без разницы. А мы с Вами плавно возвращаемся к Правилам форума, где русским по желтенькому написано "старайтесь сохранить структуру, расположение таблиц, ... - аналогично оригиналу". Какой пример дали - такой ответ и получили.
Если со столбца В, то вот так нужно [vba]
Код
ws.UsedRange.Offset(3,1).Copy .Range("B" & r1_)
[/vba]
======== Добавлено Если таблицы начинаются со столбца В, то в столбце А пусто? Тогда какая Вам разница - с А переносим или с В?
А макрос и у меня переносил со столбца А. В Вашем примере в А ничего нет, поэтому без разницы. А мы с Вами плавно возвращаемся к Правилам форума, где русским по желтенькому написано "старайтесь сохранить структуру, расположение таблиц, ... - аналогично оригиналу". Какой пример дали - такой ответ и получили.
Если со столбца В, то вот так нужно [vba]
Код
ws.UsedRange.Offset(3,1).Copy .Range("B" & r1_)
[/vba]
======== Добавлено Если таблицы начинаются со столбца В, то в столбце А пусто? Тогда какая Вам разница - с А переносим или с В?_Boroda_
Структура файлов всегда была одинаковой, Александр. По сути вопроса, вначале макрос переносил табличную часть со столбца В на лист СВОД в столбец А (а нужно было в столбец В). В последнем случае макрос начинает переносить со столбца С одного листа в столбец В листа СВОД.
Структура файлов всегда была одинаковой, Александр. По сути вопроса, вначале макрос переносил табличную часть со столбца В на лист СВОД в столбец А (а нужно было в столбец В). В последнем случае макрос начинает переносить со столбца С одного листа в столбец В листа СВОД.Мурад
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Извините, что замучил вас невнятными объяснениями)
