Пример реальной книги во вложении. В реальной - больше строк и 15-20 листов для объединения на один. Структура тестовой таблицы в точности повторяет реальную.
Нужно объединить таблицы со всех листов (за исключением листов "Тест" и "Данные") на лист "Svod" в одну таблицу, но только нужные столбцы. Полезные данные в листах для объединения начинаются с ячейки A9. Вниз с А9 и вправо - это и есть табличка, которую нужно поместить на лист Svod. Только не всю, а выделенные оранжевым столбцы.
То есть, перенести нужные столбцы одного листа на свод и указать имя листа откуда взято, затем посмотреть второй лист и так далее. И исключить из консолидации два листа "Тест" и "Данные".
На листе "Svod" есть кнопочка с макросом, он объединяет таблички, в случае, если выше полезных данных нет мусора, а без него никак. В моем случае прошу помочь с табличками.
Пример реальной книги во вложении. В реальной - больше строк и 15-20 листов для объединения на один. Структура тестовой таблицы в точности повторяет реальную.
Нужно объединить таблицы со всех листов (за исключением листов "Тест" и "Данные") на лист "Svod" в одну таблицу, но только нужные столбцы. Полезные данные в листах для объединения начинаются с ячейки A9. Вниз с А9 и вправо - это и есть табличка, которую нужно поместить на лист Svod. Только не всю, а выделенные оранжевым столбцы.
То есть, перенести нужные столбцы одного листа на свод и указать имя листа откуда взято, затем посмотреть второй лист и так далее. И исключить из консолидации два листа "Тест" и "Данные".
На листе "Svod" есть кнопочка с макросом, он объединяет таблички, в случае, если выше полезных данных нет мусора, а без него никак. В моем случае прошу помочь с табличками.w00t
Sub www() Dim ws As Worksheet, l& With Sheets("Svod") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = "Svod" And Not ws.Name = "Данные" And Not ws.Name = "Тест" Then On Error Resume Next l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 If l < 1 Then l = 1
'Intersect(ws.UsedRange.Offset(7), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l)'в Offset(7) - нужно указать с какой строки собирать -2 Intersect(Range(ws.Cells(9, "a"), ws.Cells.Find("*", ws.[a1], xlFormulas, 1, 1, 2)), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l) 'но лучше так End If Next End With End Sub
[/vba]
ну если не сильно изменять Ваш код то так: [vba]
Код
Sub www() Dim ws As Worksheet, l& With Sheets("Svod") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = "Svod" And Not ws.Name = "Данные" And Not ws.Name = "Тест" Then On Error Resume Next l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 If l < 1 Then l = 1
'Intersect(ws.UsedRange.Offset(7), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l)'в Offset(7) - нужно указать с какой строки собирать -2 Intersect(Range(ws.Cells(9, "a"), ws.Cells.Find("*", ws.[a1], xlFormulas, 1, 1, 2)), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l) 'но лучше так End If Next End With End Sub
+ заранее на листе Svod оставил первую строку с заголовками. Потому что на листе свод нужна лишь одна строка заголовков, а под нее выдернуть все данные без заголовков их нужных столбцов всех листов.
Только как оптимально прописать в коде, чтобы в столбец E на листе Svod вставлялось имя листа, из которого скопированы данные?
Так, спасибо.
Поменял строку, с 9 на 10: [vba]
Код
Intersect(Range(ws.Cells(10, "a")
[/vba]
+ заранее на листе Svod оставил первую строку с заголовками. Потому что на листе свод нужна лишь одна строка заголовков, а под нее выдернуть все данные без заголовков их нужных столбцов всех листов.
Только как оптимально прописать в коде, чтобы в столбец E на листе Svod вставлялось имя листа, из которого скопированы данные?w00t
Sub ertert() Dim wsh As Worksheet, i& Sheets("Svod").UsedRange.Offset(1).ClearContents For Each wsh In Worksheets Select Case wsh.Name Case "Svod", "Тест", "Данные" Case Else With wsh.Range("A10:P" & wsh.Cells(Rows.Count, 1).End(xlUp).Row) i = Sheets("Svod").Cells(Rows.Count, 1).End(xlUp)(2, 1).Row Union(.Columns(1), .Columns(5), .Columns(13), .Columns(16)).Copy Sheets("Svod").Cells(i, 1) Sheets("Svod").Cells(i, 5).Resize(.Rows.Count).Value = wsh.Name End With End Select Next End Sub
[/vba]
не увидел, что ответ уже есть. Но все равно попробовать можно
можно так попробовать: [vba]
Код
Sub ertert() Dim wsh As Worksheet, i& Sheets("Svod").UsedRange.Offset(1).ClearContents For Each wsh In Worksheets Select Case wsh.Name Case "Svod", "Тест", "Данные" Case Else With wsh.Range("A10:P" & wsh.Cells(Rows.Count, 1).End(xlUp).Row) i = Sheets("Svod").Cells(Rows.Count, 1).End(xlUp)(2, 1).Row Union(.Columns(1), .Columns(5), .Columns(13), .Columns(16)).Copy Sheets("Svod").Cells(i, 1) Sheets("Svod").Cells(i, 5).Resize(.Rows.Count).Value = wsh.Name End With End Select Next End Sub
[/vba]
не увидел, что ответ уже есть. Но все равно попробовать можно nilem
Яндекс.Деньги 4100159601573
Сообщение отредактировал nilem - Пятница, 01.07.2016, 23:31
Sub www() Dim ws As Worksheet, l& With Sheets("Svod") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = "Svod" And Not ws.Name = "Данные" And Not ws.Name = "Тест" Then On Error Resume Next l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 If l < 1 Then l = 1 Intersect(Range(ws.Cells(10, "a"), ws.Cells.Find("*", ws.[a1], xlFormulas, 1, 1, 2)), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l) 'но лучше так Range("e" & l & ":e" & .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row) = ws.Name End If Next End With End Sub
Sub www() Dim ws As Worksheet, l& With Sheets("Svod") .UsedRange.Offset(1).ClearContents For Each ws In Worksheets If Not ws.Name = "Svod" And Not ws.Name = "Данные" And Not ws.Name = "Тест" Then On Error Resume Next l = .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row + 1 If l < 1 Then l = 1 Intersect(Range(ws.Cells(10, "a"), ws.Cells.Find("*", ws.[a1], xlFormulas, 1, 1, 2)), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l) 'но лучше так Range("e" & l & ":e" & .Cells.Find("*", [a1], xlFormulas, 1, 1, 2).Row) = ws.Name End If Next End With End Sub
не увидел, что ответ уже есть. Но все равно попробовать можно
Все так, спасибо :)
Но у меня интерес просто, чтобы понять эту часть кода [vba]
Код
'Intersect(ws.UsedRange.Offset(7), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l)'в Offset(7) - нужно указать с какой строки собирать -2 Intersect(Range(ws.Cells(9, "a"), ws.Cells.Find("*", ws.[a1], xlFormulas, 1, 1, 2)), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l) 'но лучше так
[/vba] которая закомментирована - работает как надо, только Offset(8). Которая наоборот, активна - не совсем. Поясню суть: столбик непрерывный только в a10 и далее, прочие могут быть любыми. Например, если очистить из последнего сообщения с файлом всего лишь одну строчку на Листе 1, в ячейке P21. То на листе Svod все, кроме первого столбика - будет пустым.
не увидел, что ответ уже есть. Но все равно попробовать можно
Все так, спасибо :)
Но у меня интерес просто, чтобы понять эту часть кода [vba]
Код
'Intersect(ws.UsedRange.Offset(7), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l)'в Offset(7) - нужно указать с какой строки собирать -2 Intersect(Range(ws.Cells(9, "a"), ws.Cells.Find("*", ws.[a1], xlFormulas, 1, 1, 2)), ws.Range("a:a,e:e,m:m,p:p")).Copy .Range("a" & l) 'но лучше так
[/vba] которая закомментирована - работает как надо, только Offset(8). Которая наоборот, активна - не совсем. Поясню суть: столбик непрерывный только в a10 и далее, прочие могут быть любыми. Например, если очистить из последнего сообщения с файлом всего лишь одну строчку на Листе 1, в ячейке P21. То на листе Svod все, кроме первого столбика - будет пустым.