ЗДРАВСТВУЙТЕ УВАЖАЕМЫЕ ФОРУМЧАНЕ! Подскажите пожалуйста , если знаете , может есть такой код, есть больше тысячи листов в каждом по несколько таблиц , как автоматически скопировать данные с каждого листа с нескольких диапазонов (E1:E29;J1:J29)(диапазоны для копирования у всех листов одинаковые) и вставить их на один новый лист , с постоянным смещением через ячейку в право , что-бы не уничтожились прежние данные. К примеру : с первого листа вставляется в диапазон A1:A29;B1:B29 , со второго в D1:D29;E1:E29 , с третьего в G1:G29;H1:H29 и т.д
Копирование данных с множества листов и вставкой на один лист , с постоянным смещением .
17.12.2010 23:46:40
|
|
|
|
18.12.2010 00:16:00
Здравствуйте! Загляните в раздел "Приемы".
|
|
|
|
18.12.2010 01:16:14
Я не знаю, где Вы нашли этот код. :-) Я говорил про это:
|
|
|
|
18.12.2010 01:28:20
Спасибо , за нужную информацию!
|
|
|
|
18.12.2010 01:47:15
{quote}{login=Саша11Е}{date=17.12.2010 11:46}{thema=Копирование данных с множества листов и вставкой на один лист , с постоянным смещением .}{post} есть больше тысячи листов в каждом по несколько таблиц {/post}{/quote} <BR>Вы не ошиблись - так много листов в книге? Я давал ссылку, предположив, что Вам нужно собирать из множества книг :-) Но там есть ещё ссылка на PLEX. Если же Вам необходима сборка именно с листов одной книги, попробуйте выбрать что-нибудь здесь:
<HR> |
|
|
|
18.12.2010 03:18:57
Вот нашёл сам ,что мне было нужно (правда на сайте
Option Explicit Sub Consolidated_Range_of_Books_and_Sheets() Dim iBeginRange As Object, lCalc As Long Dim sRngAddress As String, oAwb As String, sCopyAddress As String, sSheetName As String Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles On Error Resume Next Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) If iBeginRange Is Nothing Then Exit Sub sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр") If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True) If VarType(avFiles) = vbBoolean Then Exit Sub bPolyBooks = True Else avFiles = Array(ThisWorkbook.FullName) End If With Application lCalc = .Calculation .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) Set wsDataSheet = ThisWorkbook.ActiveSheet For li = LBound(avFiles) To UBound(avFiles) If bPolyBooks Then Workbooks.Open Filename:=avFiles(li) oAwb = Dir(avFiles(li), vbDirectory) For Each wsSh In Workbooks(oAwb).Sheets If wsSh.Name Like sSheetName Then If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_ With wsSh Select Case iBeginRange.Count Case 1 lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = .Cells.SpecialCells(xlLastCell).Column sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address Case Else sCopyAddress = iBeginRange.Address lLastrow = iBeginRange.Rows.Count iLastColumn = iBeginRange.Columns.Count End Select lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1 sRngAddress = .Range(.Cells(lLastRowMyBook, 1), .Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address .Range(sCopyAddress).Copy wsDataSheet.Range(sRngAddress) End With End If NEXT_: Next wsSh If bPolyBooks Then Workbooks(oAwb).Close False Next li With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc End With End Sub |
|
|
|
21.09.2011 15:48:42
Здравствуйте, макрос замечательный, но выдает ошибку в строке:
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) Листов у меня более 100, может кто посоветовать решение? |
|
|
|
21.09.2011 16:11:27
Если при меньшем количестве листов этой ошибки не возникает, то не хватает ресурсов Вашей машины.
|
|
|
|
21.09.2011 19:01:54
Конечно можно:
ThisWorkbook.Sheets.Add After:=Sheets("Сводная") |
||||
|
|
|||