Имеется документ в котором таблица раскидана по листам, необходимо собрать ее в кучу, попытался записью макроса сделать (в написании макросов не силен), но не смог его применить. Итак на 2 листе документа желаемый результат, а вот на 3,4,5 листах разрозненный блок таблицы. Необходимо в 3 лист вставить пустую строку над 2 строкой (иначе последующее копирование будет идти со смещением) и затем скопировать содержимое листа 4 в лист 3 начиная со столбца F, далее скопировать содержимое 5 листа в 3 лист начиная со столбца J, таким образом должна получиться таблица как на листе 2. Вообще хотелось бы конечно затем удалить ненужные 4 и 5 лист и повторить процедуру для листов 6,7,8 и так далее до конца документа. Ну и совсем идеально было бы, полученные результаты добавить продолжением таблицы на листе 2, чтобы получилась цельная таблица.
Что сделал я:
Записал автоматический макрос для листов 3,4,5 и при попытке применить его дальше ничего не получается так как он корректен только для этих листов, менять вручную каждый раз легче таблицу вручную пере копировать, а так как файл этот состоит из 48 листов работа трудоемкая к тому же периодическая, раз в месяц, очень буду признателен подсказке, почитал форум похоже ничего не нашел(
Имеется документ в котором таблица раскидана по листам, необходимо собрать ее в кучу, попытался записью макроса сделать (в написании макросов не силен), но не смог его применить. Итак на 2 листе документа желаемый результат, а вот на 3,4,5 листах разрозненный блок таблицы. Необходимо в 3 лист вставить пустую строку над 2 строкой (иначе последующее копирование будет идти со смещением) и затем скопировать содержимое листа 4 в лист 3 начиная со столбца F, далее скопировать содержимое 5 листа в 3 лист начиная со столбца J, таким образом должна получиться таблица как на листе 2. Вообще хотелось бы конечно затем удалить ненужные 4 и 5 лист и повторить процедуру для листов 6,7,8 и так далее до конца документа. Ну и совсем идеально было бы, полученные результаты добавить продолжением таблицы на листе 2, чтобы получилась цельная таблица.
Что сделал я:
Записал автоматический макрос для листов 3,4,5 и при попытке применить его дальше ничего не получается так как он корректен только для этих листов, менять вручную каждый раз легче таблицу вручную пере копировать, а так как файл этот состоит из 48 листов работа трудоемкая к тому же периодическая, раз в месяц, очень буду признателен подсказке, почитал форум похоже ничего не нашел(
Ваш задача не из самых простых, но решаема, только вот некоторые вопросы надо выяснить. Как формируется этот файл? 1. Вы его получаете как есть с 48-ю листами и вам придется в него каждый раз вставлять макрос. 2. У вас будет постоянный файл и в него будут вносится 48 листов. 3. Листы всегда идут в одинаковой последовательности? 4. Количество колонок во всех листах одинаковое? Остальное вроде понятно. Информация нужна не только мне, а всем кто возьмётся помочь.
Ваш задача не из самых простых, но решаема, только вот некоторые вопросы надо выяснить. Как формируется этот файл? 1. Вы его получаете как есть с 48-ю листами и вам придется в него каждый раз вставлять макрос. 2. У вас будет постоянный файл и в него будут вносится 48 листов. 3. Листы всегда идут в одинаковой последовательности? 4. Количество колонок во всех листах одинаковое? Остальное вроде понятно. Информация нужна не только мне, а всем кто возьмётся помочь.Wasilich
можно в личной книге макросов сохранить и запускать его из открытой книги с любым количеством листов кратное трем(если не кратно, последние 1-2 листа игнорирует макрос), главное чтобы структура листов была такая же как в образце
[vba]
Код
Sub Reforms_avto() Dim str As String, shStart As Variant, gr As Integer If MsgBox("преобразуем таблицы? отмена будет не возможна, перед сохранением документа проверьте корректность информации", vbOKCancel, "ВНИМАНИЕ!!!") = vbCancel Then Exit Sub str = "" gr = ActiveWorkbook.Sheets.Count / 3 If gr * 3 <> ActiveWorkbook.Sheets.Count Then If MsgBox("количество листов в документе не кратно 3, продолжить?", vbOKCancel, "Внимание!!!") = vbCancel Then Exit Sub For f = 1 To gr shStart = 1 + (f - 1) * 3 + (f - 1) If 2 + shStart > ActiveWorkbook.Sheets.Count Then MsgBox "Для работы макроса необходимо три листа с данными", vbCritical, "ОШИБКА ВВОДА": Exit Sub
можно в личной книге макросов сохранить и запускать его из открытой книги с любым количеством листов кратное трем(если не кратно, последние 1-2 листа игнорирует макрос), главное чтобы структура листов была такая же как в образце
[vba]
Код
Sub Reforms_avto() Dim str As String, shStart As Variant, gr As Integer If MsgBox("преобразуем таблицы? отмена будет не возможна, перед сохранением документа проверьте корректность информации", vbOKCancel, "ВНИМАНИЕ!!!") = vbCancel Then Exit Sub str = "" gr = ActiveWorkbook.Sheets.Count / 3 If gr * 3 <> ActiveWorkbook.Sheets.Count Then If MsgBox("количество листов в документе не кратно 3, продолжить?", vbOKCancel, "Внимание!!!") = vbCancel Then Exit Sub For f = 1 To gr shStart = 1 + (f - 1) * 3 + (f - 1) If 2 + shStart > ActiveWorkbook.Sheets.Count Then MsgBox "Для работы макроса необходимо три листа с данными", vbCritical, "ОШИБКА ВВОДА": Exit Sub
пример с 9ю листами не влез в 100кб, поэтому оставил 6 работать будет с любым количеством
попробовал применить данный макрос к документу не получилось. Открыл Ваш файл там все отлично сработало! Затем открыл свой файл и попытался применить макрос туда, получил ошибку 400, закрыл все документы, затем открыл свой документ и добавил код макроса получилась другая ошибка (скрин во вложении) листов кратно 3. в чем причина не понимаю. Но Вам спасибо огромное за отзывчивость!
пример с 9ю листами не влез в 100кб, поэтому оставил 6 работать будет с любым количеством
попробовал применить данный макрос к документу не получилось. Открыл Ваш файл там все отлично сработало! Затем открыл свой файл и попытался применить макрос туда, получил ошибку 400, закрыл все документы, затем открыл свой документ и добавил код макроса получилась другая ошибка (скрин во вложении) листов кратно 3. в чем причина не понимаю. Но Вам спасибо огромное за отзывчивость!163tiger163
код криво на форуме отобразился, поправила, попробуйте еще раз его скопировать.
Спасибо все работает!!! А может подскажите как сделать еще один макрос который будет складывать получившиеся таблицы в одну, я так понимаю он будет похож на этот, но в коде не могу разобраться, или же это новый макрос писать? (наглеть не хочу итак сильно помогли, если трудоемкая задача то не нужно, ручками буду делать).
На всякий во вложении добавил документ с уже удаленными лишними страницами
код криво на форуме отобразился, поправила, попробуйте еще раз его скопировать.
Спасибо все работает!!! А может подскажите как сделать еще один макрос который будет складывать получившиеся таблицы в одну, я так понимаю он будет похож на этот, но в коде не могу разобраться, или же это новый макрос писать? (наглеть не хочу итак сильно помогли, если трудоемкая задача то не нужно, ручками буду делать).
На всякий во вложении добавил документ с уже удаленными лишними страницами163tiger163
Sub All_to_One() Dim str As String, isc As Integer, gr As Integer, lr As Integer, RowsCollect As Range, tr As Integer, tn As String If MsgBox("объединение всех листов, отмена невозможна", vbOKCancel, "внимание!!!") = vbCancel Then Exit Sub str = "" gr = ActiveWorkbook.Sheets.Count tn = ActiveSheet.Name ActiveWorkbook.Sheets.Add ActiveSheet.Name = "ALL" ActiveWorkbook.Sheets("ALL").Cells(1, 1).Select isc = ActiveWorkbook.Sheets("ALL").Index gr = ActiveWorkbook.Sheets.Count ActiveWorkbook.Sheets(tn).Select ActiveWorkbook.Sheets(tn).Rows("1:2").Select Selection.Copy ActiveWorkbook.Sheets(isc).Select ActiveWorkbook.Sheets(isc).Cells(1, 1).Select ActiveSheet.Paste tr = 3 For f = 1 To gr If f <> isc Then lr = ActiveWorkbook.Sheets(f).Cells.SpecialCells(xlLastCell).Row ActiveWorkbook.Sheets(f).Select ActiveWorkbook.Sheets(f).Rows("3:" & lr).Select Selection.Copy ActiveWorkbook.Sheets(isc).Select ActiveWorkbook.Sheets(isc).Cells(tr, 1).Select ActiveSheet.Paste tr = tr + lr - 2 End If Next f ' чистим ActiveWorkbook.Sheets.Application.DisplayAlerts = False For Each Sheet In ActiveWorkbook.Sheets If Sheet.Index <> isc Then Sheet.Delete Next Sheet ActiveWorkbook.Sheets.Application.DisplayAlerts = True End Sub
[/vba] должно работать так :-)
[vba]
Код
Sub All_to_One() Dim str As String, isc As Integer, gr As Integer, lr As Integer, RowsCollect As Range, tr As Integer, tn As String If MsgBox("объединение всех листов, отмена невозможна", vbOKCancel, "внимание!!!") = vbCancel Then Exit Sub str = "" gr = ActiveWorkbook.Sheets.Count tn = ActiveSheet.Name ActiveWorkbook.Sheets.Add ActiveSheet.Name = "ALL" ActiveWorkbook.Sheets("ALL").Cells(1, 1).Select isc = ActiveWorkbook.Sheets("ALL").Index gr = ActiveWorkbook.Sheets.Count ActiveWorkbook.Sheets(tn).Select ActiveWorkbook.Sheets(tn).Rows("1:2").Select Selection.Copy ActiveWorkbook.Sheets(isc).Select ActiveWorkbook.Sheets(isc).Cells(1, 1).Select ActiveSheet.Paste tr = 3 For f = 1 To gr If f <> isc Then lr = ActiveWorkbook.Sheets(f).Cells.SpecialCells(xlLastCell).Row ActiveWorkbook.Sheets(f).Select ActiveWorkbook.Sheets(f).Rows("3:" & lr).Select Selection.Copy ActiveWorkbook.Sheets(isc).Select ActiveWorkbook.Sheets(isc).Cells(tr, 1).Select ActiveSheet.Paste tr = tr + lr - 2 End If Next f ' чистим ActiveWorkbook.Sheets.Application.DisplayAlerts = False For Each Sheet In ActiveWorkbook.Sheets If Sheet.Index <> isc Then Sheet.Delete Next Sheet ActiveWorkbook.Sheets.Application.DisplayAlerts = True End Sub
Макрос выдает ошибку 1004 и ругается на вот эту строчку If Sheet.Index <> isc Then Sheet.Delete Сам докумет же остается с одним листом а остальные листы не прибавляются а просто пропадают
Макрос выдает ошибку 1004 и ругается на вот эту строчку If Sheet.Index <> isc Then Sheet.Delete Сам докумет же остается с одним листом а остальные листы не прибавляются а просто пропадают
попробовал еще раз на своем файлике выдало ошибку, затем решил сделать документ с 0 и применить оба макроса все сработало! Никогда ранее не сталкивался с такими возможностями excel, оказывается тут тоже нужны крайне глубокие познания для использования по максимуму возможностей! Спасибо Вам за отзывчивость.
попробовал еще раз на своем файлике выдало ошибку, затем решил сделать документ с 0 и применить оба макроса все сработало! Никогда ранее не сталкивался с такими возможностями excel, оказывается тут тоже нужны крайне глубокие познания для использования по максимуму возможностей! Спасибо Вам за отзывчивость.163tiger163
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
