Данные со всех листов в один

#1
Александр

Отправлено 13 Июль 2015

Проходимец

1 сообщений
0 благодарностей

Office:2013

Уважаемые пользователи, всем доброго дня!

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

Нашёл на просторах Интернета макрос один и хотел воспользоваться им, но что-то не получается, т.к. каждый раз количество строк разное. Может этот макрос можно как-то подправить под данную задачу?

Sub sborka()If MsgBox("Сборка производится на первый лист, правильно?", vbYesNo + vbDefaultButton2) = 6 ThenSheets(1).Range("a1").CurrentRegion.Clears_ = Sheets.CountSheets(2).Range("1:1").Copy Sheets(1).Range("a1")For i = 2 To s_    r_ = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1    Sheets(i).Range("a1").CurrentRegion.Offset(1).Copy Sheets(1).Range("a" & r_)NextEnd IfEnd Sub

Да, кстати, ещё прикрепляю сам файл.

СКАЧАТЬ

Вес: 10,25К

Загрузок: 64

Заранее благодарю за помощь.

#2
Fisher

Отправлено 13 Июль 2015

Новичок

14 сообщений
0 благодарностей

Город:Киров
Office:2010, 2013

Есть такая надстройка MyAddin, там есть такая возможность, я ей очень давно пользуюсь

#3
Thomas

Отправлено 13 Июль 2015

Excel Pro

61 сообщений
10 благодарностей

Город:Москва
Office:2003, 2010, 2013, Online

Александр, ну вот собственно сам код макроса:

Sub sborka()If MsgBox("Сборка производится на первый лист, правильно?", vbYesNo + vbDefaultButton2) = 6 ThenSheets(1).Range("a1").CurrentRegion.Clears_ = Sheets.CountSheets(2).Range("1:1").Copy Sheets(1).Range("a1")For i = 2 To s_    r_ = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1    Sheets(i).Range("a1").CurrentRegion.Offset(1).Copy Sheets(1).Range("a" & r_)    Range("d" & r_) = Sheets(i).NameNext    r_ = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row    Range("d2:d" & r_).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"    Range("d2:d" & r_).Value = Range("d2:d" & r_).ValueEnd IfEnd Sub

А вот прикрепил готовый файл

СКАЧАТЬ

Вес: 20,68К

Загрузок: 98

Так пойдёт?