Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Много листов, необходимо свести каждые 3 листа в один - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Много листов, необходимо свести каждые 3 листа в один (Макросы/Sub)
Много листов, необходимо свести каждые 3 листа в один
163tiger163 Дата: Вторник, 29.11.2016, 10:07 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Имеется документ в котором таблица раскидана по листам, необходимо собрать ее в кучу, попытался записью макроса сделать (в написании макросов не силен), но не смог его применить.
Итак на 2 листе документа желаемый результат, а вот на 3,4,5 листах разрозненный блок таблицы. Необходимо в 3 лист вставить пустую строку над 2 строкой (иначе последующее копирование будет идти со смещением) и затем скопировать содержимое листа 4 в лист 3 начиная со столбца F, далее скопировать содержимое 5 листа в 3 лист начиная со столбца J, таким образом должна получиться таблица как на листе 2.
Вообще хотелось бы конечно затем удалить ненужные 4 и 5 лист и повторить процедуру для листов 6,7,8 и так далее до конца документа.
Ну и совсем идеально было бы, полученные результаты добавить продолжением таблицы на листе 2, чтобы получилась цельная таблица.

Что сделал я:

Записал автоматический макрос для листов 3,4,5 и при попытке применить его дальше ничего не получается так как он корректен только для этих листов, менять вручную каждый раз легче таблицу вручную пере копировать, а так как файл этот состоит из 48 листов работа трудоемкая к тому же периодическая, раз в месяц, очень буду признателен подсказке, почитал форум похоже ничего не нашел(

[vba]
Код
Sub Макрос1()
'
' Макрос3 Макрос
'

'
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Table 4").Select
Range("A1:D45").Select
Selection.Copy
Sheets("Table 3").Select
Range("F1:I1").Select
ActiveSheet.Paste
Sheets("Table 5").Select
Range("A1:H45").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Table 3").Select
Range("J1").Select
ActiveSheet.Paste
Sheets("Table 4").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Sheets("Table 5").Select
ActiveWindow.SelectedSheets.Delete
End Sub
[/vba]
Помогите добры молодцы кто чем сможет!
К сообщению приложен файл: -_.xls(90Kb)


Сообщение отредактировал Manyasha - Вторник, 29.11.2016, 10:18
 
Ответить
СообщениеИмеется документ в котором таблица раскидана по листам, необходимо собрать ее в кучу, попытался записью макроса сделать (в написании макросов не силен), но не смог его применить.
Итак на 2 листе документа желаемый результат, а вот на 3,4,5 листах разрозненный блок таблицы. Необходимо в 3 лист вставить пустую строку над 2 строкой (иначе последующее копирование будет идти со смещением) и затем скопировать содержимое листа 4 в лист 3 начиная со столбца F, далее скопировать содержимое 5 листа в 3 лист начиная со столбца J, таким образом должна получиться таблица как на листе 2.
Вообще хотелось бы конечно затем удалить ненужные 4 и 5 лист и повторить процедуру для листов 6,7,8 и так далее до конца документа.
Ну и совсем идеально было бы, полученные результаты добавить продолжением таблицы на листе 2, чтобы получилась цельная таблица.

Что сделал я:

Записал автоматический макрос для листов 3,4,5 и при попытке применить его дальше ничего не получается так как он корректен только для этих листов, менять вручную каждый раз легче таблицу вручную пере копировать, а так как файл этот состоит из 48 листов работа трудоемкая к тому же периодическая, раз в месяц, очень буду признателен подсказке, почитал форум похоже ничего не нашел(

[vba]
Код
Sub Макрос1()
'
' Макрос3 Макрос
'

'
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Table 4").Select
Range("A1:D45").Select
Selection.Copy
Sheets("Table 3").Select
Range("F1:I1").Select
ActiveSheet.Paste
Sheets("Table 5").Select
Range("A1:H45").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Table 3").Select
Range("J1").Select
ActiveSheet.Paste
Sheets("Table 4").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Sheets("Table 5").Select
ActiveWindow.SelectedSheets.Delete
End Sub
[/vba]
Помогите добры молодцы кто чем сможет!

Автор - 163tiger163
Дата добавления - 29.11.2016 в 10:07
K-SerJC Дата: Вторник, 29.11.2016, 12:01 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 11 ±
Замечаний: 60% ±

Excel 2013
так пойдет?

при желании можно зациклить на все листы книги, если есть уверенность что там всегда по три листа подряд идут в одинаковой последовательности

автозапуск добавил при открытии


Благими намерениями выстелена дорога в АД.

Сообщение отредактировал K-SerJC - Вторник, 29.11.2016, 12:12
 
Ответить
Сообщениетак пойдет?

при желании можно зациклить на все листы книги, если есть уверенность что там всегда по три листа подряд идут в одинаковой последовательности

автозапуск добавил при открытии

Автор - K-SerJC
Дата добавления - 29.11.2016 в 12:01
K-SerJC Дата: Вторник, 29.11.2016, 12:53 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 11 ±
Замечаний: 60% ±

Excel 2013
вот за "loop"ил :-)
вторая версия
пример с 9ю листами не влез в 100кб, поэтому оставил 6
работать будет с любым количеством
К сообщению приложен файл: avto_163tiger16.xls(81Kb)


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщениевот за "loop"ил :-)
вторая версия
пример с 9ю листами не влез в 100кб, поэтому оставил 6
работать будет с любым количеством

Автор - K-SerJC
Дата добавления - 29.11.2016 в 12:53
Wasilich Дата: Вторник, 29.11.2016, 14:55 | Сообщение № 4
Группа: Друзья
Ранг: Ветеран
Сообщений: 855
Репутация: 220 ±
Замечаний: 0% ±

2003
файл этот состоит из 48 листов
Ваш задача не из самых простых, но решаема, только вот некоторые вопросы надо выяснить.
Как формируется этот файл?
1. Вы его получаете как есть с 48-ю листами и вам придется в него каждый раз вставлять макрос.
2. У вас будет постоянный файл и в него будут вносится 48 листов.
3. Листы всегда идут в одинаковой последовательности?
4. Количество колонок во всех листах одинаковое?
Остальное вроде понятно. Информация нужна не только мне, а всем кто возьмётся помочь.
 
Ответить
Сообщение
файл этот состоит из 48 листов
Ваш задача не из самых простых, но решаема, только вот некоторые вопросы надо выяснить.
Как формируется этот файл?
1. Вы его получаете как есть с 48-ю листами и вам придется в него каждый раз вставлять макрос.
2. У вас будет постоянный файл и в него будут вносится 48 листов.
3. Листы всегда идут в одинаковой последовательности?
4. Количество колонок во всех листах одинаковое?
Остальное вроде понятно. Информация нужна не только мне, а всем кто возьмётся помочь.

Автор - Wasilich
Дата добавления - 29.11.2016 в 14:55
K-SerJC Дата: Среда, 30.11.2016, 07:52 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 76
Репутация: 11 ±
Замечаний: 60% ±

Excel 2013
придется в него каждый раз вставлять макрос.

можно в личной книге макросов сохранить и запускать его из открытой книги с любым количеством листов кратное трем(если не кратно, последние 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

str = ActiveWorkbook.Sheets(shStart).Name & " - " & ActiveWorkbook.Sheets(1 + shStart).Name & " - " & ActiveWorkbook.Sheets(2 + shStart).Name
ActiveWorkbook.Sheets.Add Before:=ActiveWorkbook.Sheets(shStart)
ActiveSheet.Name = str
ActiveWorkbook.Sheets(1 + shStart).Select
ActiveWorkbook.Sheets(1 + shStart).Range("A:E").Select
Selection.Copy
ActiveWorkbook.Sheets(shStart).Select
ActiveWorkbook.Sheets(shStart).Range("A1").Select
ActiveSheet.Paste

ActiveSheet.Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

ActiveWorkbook.Sheets(2 + shStart).Select
ActiveWorkbook.Sheets(2 + shStart).Range("A <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> ").Select
Selection.Copy
ActiveWorkbook.Sheets(shStart).Select
ActiveWorkbook.Sheets(shStart).Range("F1").Select
ActiveSheet.Paste

ActiveWorkbook.Sheets(3 + shStart).Select
ActiveWorkbook.Sheets(3 + shStart).Range("A:H").Select
Selection.Copy
ActiveWorkbook.Sheets(shStart).Select
ActiveWorkbook.Sheets(shStart).Range("J1").Select
ActiveSheet.Paste

Next f
End Sub
[/vba]

главное не перепутать, если еще другие книги открыты, макрос запускать надо когда активна именно эта книга.
К сообщению приложен файл: reforms_auto.bas(2Kb)


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщение
придется в него каждый раз вставлять макрос.

можно в личной книге макросов сохранить и запускать его из открытой книги с любым количеством листов кратное трем(если не кратно, последние 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

str = ActiveWorkbook.Sheets(shStart).Name & " - " & ActiveWorkbook.Sheets(1 + shStart).Name & " - " & ActiveWorkbook.Sheets(2 + shStart).Name
ActiveWorkbook.Sheets.Add Before:=ActiveWorkbook.Sheets(shStart)
ActiveSheet.Name = str
ActiveWorkbook.Sheets(1 + shStart).Select
ActiveWorkbook.Sheets(1 + shStart).Range("A:E").Select
Selection.Copy
ActiveWorkbook.Sheets(shStart).Select
ActiveWorkbook.Sheets(shStart).Range("A1").Select
ActiveSheet.Paste

ActiveSheet.Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

ActiveWorkbook.Sheets(2 + shStart).Select
ActiveWorkbook.Sheets(2 + shStart).Range("A <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> ").Select
Selection.Copy
ActiveWorkbook.Sheets(shStart).Select
ActiveWorkbook.Sheets(shStart).Range("F1").Select
ActiveSheet.Paste

ActiveWorkbook.Sheets(3 + shStart).Select
ActiveWorkbook.Sheets(3 + shStart).Range("A:H").Select
Selection.Copy
ActiveWorkbook.Sheets(shStart).Select
ActiveWorkbook.Sheets(shStart).Range("J1").Select
ActiveSheet.Paste

Next f
End Sub
[/vba]

главное не перепутать, если еще другие книги открыты, макрос запускать надо когда активна именно эта книга.

Автор - K-SerJC
Дата добавления - 30.11.2016 в 07:52
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Много листов, необходимо свести каждые 3 листа в один (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!