Перейти к содержимому

Фотография
- - - - -

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


  • Авторизуйтесь для ответа в теме
Сообщений в теме: 4

#1
Александр

Александр

    Проходимец

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

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

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

 

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

Sub sborka()
If MsgBox("Сборка производится на первый лист, правильно?", vbYesNo + vbDefaultButton2) = 6 Then
Sheets(1).Range("a1").CurrentRegion.Clear
s_ = Sheets.Count
Sheets(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_)
Next
End If
End Sub

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

 

СКАЧАТЬ


 

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



#2
Fisher

Fisher

    Новичок

  • 14 сообщений
  • 0 благодарностей
1
  • Город:Киров
  • Office:2010, 2013

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



#3
Thomas

Thomas

    Excel Pro

  • 61 сообщений
  • 10 благодарностей
12
  • Город:Москва
  • Office:2003, 2010, 2013, Online

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

Sub sborka()
If MsgBox("Сборка производится на первый лист, правильно?", vbYesNo + vbDefaultButton2) = 6 Then
Sheets(1).Range("a1").CurrentRegion.Clear
s_ = Sheets.Count
Sheets(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).Name
Next
    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_).Value
End If
End Sub

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

 

СКАЧАТЬ


 

Так пойдёт?


Господа! Регистрируйтесь и задавайте свои вопросы, связанные с Microsoft Office. Поможем, чем сможем ;)


#4
TherGalt

TherGalt

    Проходимец

  • 1 сообщений
  • 0 благодарностей
Если не получается, то подскажите как лучше сделать через добавление листа и копирование содержимого? Листов несколько...

#5
Alex87

Alex87

    Главарь

  • 170 сообщений
  • 20 благодарностей
35
  • Город:Москва
  • Office:2010, 2013, 2016, для Mac

Если не получается, то подскажите как лучше сделать через добавление листа и копирование содержимого? Листов несколько...

 

Если у Вас есть файл, то лучше приложите его. Что конкретно не получается?


6cldfZs.jpg





Количество пользователей, читающих эту тему: 0

0 пользователей, 0 гостей, 0 анонимных