Тема неоднократно поднималась, пробовал некоторые найденные макросы, но необходимого результата пока не получил. Имеется файл со множеством листов (более 30), в каждом листе таблицы разных размеров (как в ширину, так и в высоту). Необходимо собрать все листы на один с добавлением столбца, в котором содержится имя листа, с которого скопированы данные. Желательно без сохранения формул, но с сохранением форматов. В примере лист "Результат" - то, что нужно получить. Заранее спасибо всем откликнувшимся.
Тема неоднократно поднималась, пробовал некоторые найденные макросы, но необходимого результата пока не получил. Имеется файл со множеством листов (более 30), в каждом листе таблицы разных размеров (как в ширину, так и в высоту). Необходимо собрать все листы на один с добавлением столбца, в котором содержится имя листа, с которого скопированы данные. Желательно без сохранения формул, но с сохранением форматов. В примере лист "Результат" - то, что нужно получить. Заранее спасибо всем откликнувшимся.Russel
1). Столбец В всегда можно использовать для поиска последней задействованной строки? 2). Строку 4 всегда можно использовать для поиска последнего задействованного столбца?
Russel, привет.
Пара уточнений:
1). Столбец В всегда можно использовать для поиска последней задействованной строки? 2). Строку 4 всегда можно использовать для поиска последнего задействованного столбца?Rioran
Роман, Москва, voronov_rv@mail.ru Яндекс-Деньги: 41001312674279
'Author: Roman Rioran Voronov 'Date: the 24-th of September, 2014 'Feedback: voronov_rv@mail.ru
'Purpose: Gathering info from all sheets
Dim shtX As Worksheet 'For Results Dim shtY As Worksheet 'To roll sheets Dim X As Long 'Row where to place info Dim Y As Long 'Rows from shtY
Set shtX = ThisWorkbook.Worksheets("Результат") X = 1
Application.ScreenUpdating = False
For Each shtY In ThisWorkbook.Worksheets If shtY.Name <> shtX.Name Then With shtY Y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 shtX.Range("A" & X & ":A" & X + Y - 1).Value = shtY.Name .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 20)).Copy shtX.Cells(X, 2).PasteSpecial Paste:=-4122 shtX.Cells(X, 2).PasteSpecial Paste:=12 X = X + Y + 1 End With End If Next shtY
'Author: Roman Rioran Voronov 'Date: the 24-th of September, 2014 'Feedback: voronov_rv@mail.ru
'Purpose: Gathering info from all sheets
Dim shtX As Worksheet 'For Results Dim shtY As Worksheet 'To roll sheets Dim X As Long 'Row where to place info Dim Y As Long 'Rows from shtY
Set shtX = ThisWorkbook.Worksheets("Результат") X = 1
Application.ScreenUpdating = False
For Each shtY In ThisWorkbook.Worksheets If shtY.Name <> shtX.Name Then With shtY Y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 shtX.Range("A" & X & ":A" & X + Y - 1).Value = shtY.Name .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 20)).Copy shtX.Cells(X, 2).PasteSpecial Paste:=-4122 shtX.Cells(X, 2).PasteSpecial Paste:=12 X = X + Y + 1 End With End If Next shtY
Rioran, если в таблице есть пустые строки - определяет их как конец таблицы (наверное надо воспользоваться решением из МШ для определения конца таблицы). Желательно чтобы лист Результат создавался автоматически (таких файлов много, хочется максимально автоматизировать).
Rioran, если в таблице есть пустые строки - определяет их как конец таблицы (наверное надо воспользоваться решением из МШ для определения конца таблицы). Желательно чтобы лист Результат создавался автоматически (таких файлов много, хочется максимально автоматизировать).Russel
Rioran, в реальном большом файле скопировались по 8-12 строк с каждого листа. При этом первая непустая ячейка в ст. А на всех листах как минимум 20-я
Rioran, в реальном большом файле скопировались по 8-12 строк с каждого листа. При этом первая непустая ячейка в ст. А на всех листах как минимум 20-яRussel
Давай взглянем на лист, с которого содрали только 8-12 строк.
Меа кульпа - я уже начал вручную собирать и добавил везде пустой столбец с именем листа под шапкой. Избавился от столбца - все заработало! Спасибо, дружище!
Давай взглянем на лист, с которого содрали только 8-12 строк.
Меа кульпа - я уже начал вручную собирать и добавил везде пустой столбец с именем листа под шапкой. Избавился от столбца - все заработало! Спасибо, дружище! Russel
Во вложении доработанный макрос. Игнорирует страницы с пустым А столбцом и создаёт свой лист итогов.
[vba]
Код
Sub Rio_Runner()
'Author: Roman Rioran Voronov 'Date: the 24-th of September, 2014 'Feedback: voronov_rv@mail.ru
'Purpose: Gathering info from all sheets
Dim shtX As Worksheet 'For Results Dim shtY As Worksheet 'To roll sheets Dim X As Long 'Row where to place info Dim Y As Long 'Rows from shtY
ThisWorkbook.Sheets.Add before:=Sheets(1) Set shtX = ThisWorkbook.ActiveSheet shtX.Name = "Allow_Me_To_Present_You_Totals" X = 1
Application.ScreenUpdating = False
For Each shtY In ThisWorkbook.Worksheets If shtY.Name <> shtX.Name Then With shtY Y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 If Y <> 2 Then shtX.Range("A" & X & ":A" & X + Y - 1).Value = shtY.Name .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 20)).Copy shtX.Cells(X, 2).PasteSpecial Paste:=-4122 shtX.Cells(X, 2).PasteSpecial Paste:=12 X = X + Y + 1 End If End With End If Next shtY
Во вложении доработанный макрос. Игнорирует страницы с пустым А столбцом и создаёт свой лист итогов.
[vba]
Код
Sub Rio_Runner()
'Author: Roman Rioran Voronov 'Date: the 24-th of September, 2014 'Feedback: voronov_rv@mail.ru
'Purpose: Gathering info from all sheets
Dim shtX As Worksheet 'For Results Dim shtY As Worksheet 'To roll sheets Dim X As Long 'Row where to place info Dim Y As Long 'Rows from shtY
ThisWorkbook.Sheets.Add before:=Sheets(1) Set shtX = ThisWorkbook.ActiveSheet shtX.Name = "Allow_Me_To_Present_You_Totals" X = 1
Application.ScreenUpdating = False
For Each shtY In ThisWorkbook.Worksheets If shtY.Name <> shtX.Name Then With shtY Y = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 If Y <> 2 Then shtX.Range("A" & X & ":A" & X + Y - 1).Value = shtY.Name .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 20)).Copy shtX.Cells(X, 2).PasteSpecial Paste:=-4122 shtX.Cells(X, 2).PasteSpecial Paste:=12 X = X + Y + 1 End If End With End If Next shtY
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
