Страницы: 1
RSS
Копирование данных с множества листов и вставкой на один лист , с постоянным смещением .
 
ЗДРАВСТВУЙТЕ УВАЖАЕМЫЕ ФОРУМЧАНЕ! Подскажите  пожалуйста , если знаете  , может есть такой код, есть больше тысячи листов в каждом по несколько таблиц , как автоматически скопировать данные с каждого листа с нескольких диапазонов (E1:E29;J1:J29)(диапазоны для копирования у всех листов одинаковые)  и вставить их на один новый лист , с постоянным смещением через ячейку в право , что-бы не уничтожились прежние данные. К примеру : с первого листа вставляется в диапазон A1:A29;B1:B29 , со второго в D1:D29;E1:E29 , с третьего в G1:G29;H1:H29 и т.д
 
Здравствуйте! Загляните в раздел "Приемы".
 
Вы имели ввиду , этот код , только немного его изменить ?  
 
 
Sub New_Multi_Table_Pivot()      
   Dim i As Long      
   Dim arSQL() As String      
   Dim objPivotCache As PivotCache      
   Dim objRS As Object      
   Dim ResultSheetName As String      
   Dim SheetsNames As Variant      
   
   'имя листа, куда будет выводиться результирующая сводная      
   ResultSheetName = "Сводная"      
   'массив имен листов с исходными таблицами      
   SheetsNames = Array("Альфа", "Бета", "Гамма", "Дельта")      
   
   'формируем кэш по таблицам с листов из SheetsNames      
   With ActiveWorkbook      
       ReDim arSQL(1 To (UBound(SheetsNames) + 1))      
       For i = LBound(SheetsNames) To UBound(SheetsNames)      
           arSQL(i + 1) = "SELECT * FROM [" & SheetsNames(i) & "$]"
       Next i      
       Set objRS = CreateObject("ADODB.Recordset")      
       objRS.Open Join$(arSQL, " UNION ALL "), _      
                  Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _      
                              .FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)      
   End With      
   
   'создаем заново лист для вывода результирующей сводной таблицы      
   On Error Resume Next      
   Application.DisplayAlerts = False      
   Worksheets(ResultSheetName).Delete      
   Set wsPivot = Worksheets.Add      
   wsPivot.Name = ResultSheetName      
   
   'выводим на этот лист сводную по сформированному кэшу      
   Set objPivotCache = ActiveWorkbook.PivotCaches.Add(xlExternal)      
   Set objPivotCache.Recordset = objRS      
   Set objRS = Nothing      
   With wsPivot      
       objPivotCache.CreatePivotTable TableDestination:=wsPivot.Range("A3")      
       Set objPivotCache = Nothing      
       Range("A3").Select      
   End With      
   
End Sub
 
Я не знаю, где Вы нашли этот код. :-) Я говорил про это: http://www.planetaexcel.ru/tip.php?aid=111<BR>А вообще подобных тем на Форуме - воз и маленькая тележка.
 
Спасибо , за нужную информацию!
 
{quote}{login=Саша11Е}{date=17.12.2010 11:46}{thema=Копирование данных с множества листов и вставкой на один лист , с постоянным смещением .}{post} есть больше тысячи листов в каждом по несколько таблиц {/post}{/quote} <BR>Вы не ошиблись - так много листов в книге? Я давал ссылку, предположив, что Вам нужно собирать из множества книг :-) Но там есть ещё ссылка на PLEX. Если же Вам необходима сборка именно с листов одной книги, попробуйте выбрать что-нибудь здесь:    
<HR>  
http://yandex.ru/sitesearch?text=%ED%E5%F1%EA%EE%EB%FC%EA%E8%F5+%EB%E8%F1%F2%EE%E2+%ED%E­0+%EE%E4%E8%ED&searchid=84804&web=0&lr=22
 
Вот нашёл сам ,что мне было нужно (правда на сайте http://www.excel-vba.ru/index.php?file=Tips_Macro_Consolidated). Сборщик данных и копирует отдельно на другой лист . Хороший код .  
 
 
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
 
Здравствуйте, макрос замечательный, но выдает ошибку в строке:    
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)  
 
Листов у меня более 100, может кто посоветовать решение?
 
Если при меньшем количестве листов этой ошибки не возникает, то не хватает ресурсов Вашей машины.
 
{quote}{login=Юрий М}{date=21.09.2011 04:11}{thema=}{post}Если при меньшем количестве листов этой ошибки не возникает, то не хватает ресурсов Вашей машины.{/post}{/quote}  
 
Сейчас проверил на 10 листах, опять такая же ошибка.
 
Юрий, вы мне уже неоднократно помогли. Подскажите, а можно вместо создания отдельной страницы, указать первую страницу, чтобы не использовать этот кусок кода. Название этой страницы "Сводная". Спасибо.
 
Конечно можно:  
ThisWorkbook.Sheets.Add After:=Sheets("Сводная")
Страницы: 1
Наверх