|
|
Регистрация Восстановить пароль |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
10.04.2012, 03:06 | #1 |
Форумчанин
Регистрация: 21.10.2011
Сообщений: 433
|
Сбор данных из нескольких листов на один с удалением дубликатов, но суммированием значений
Доброй ночи, уважаемые форумчане!
Такая вот задачка: есть периодически поступающие данные в разных книгах (в примере во вложении привел на листе 1 и листе 2). Наименований (столбец А) много и частично дублируются. Структура таблиц одинаковая (видно из листов 1 и 2). Задача-минимум: собрать данные из этих книг на один лист, убрав дубликаты, но по дубликатам просуммировав значения по столбцам с В через один и с С тоже через один. Типа сводной. Попытался решить в несколько этапов. Вот этот код Sub Consolidated_Range_of_Books_and_She ets() 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).Col umn 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(xlLa stCell).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 lCalc = .Calculation .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc End With 'добавляем столбец Columns("B:B").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove End Sub Консолидирует данные из нескольких книг (листов) на лист рабочей книги. Тут вопрос по ходу дела - консолидация всегда производится на вновь создаваемый лист. Ткните, где прописать, чтобы не на вновь создаваемый, а на Лист 2 например. В конце кода добавил столбец В для того, чтобы на втором этапе выбрать все уникальные значения из столбца А (наименования) кодом Sub Extract_Unique() 'извините содержимое не влезло End Sub и перенес их на первый лист. Остальной подсчет значений можно было бы сделать на листе 1 по всем наименованиям формулой СУММЕСЛИ. В принципе, все работает. Но, во-первых вопрос с вновь создаваемым листом (писал выше). Тогда куда будет ссылаться формула? А во-вторых, понимаю, что правой рукой чешу левое ухо. По большому счету, после первого объединения таблица должна просто обновляться, то есть добавляться вновь появившиеся строки )наименования) и добавляться все столбцы с конца. Тогда и суммирование можно производить в автомате в начале таблицы, например в столбцах В и С. Что скажете по этому поводу? Заранее спасибо. |
10.04.2012, 03:48 | #2 |
Форумчанин
Регистрация: 21.10.2011
Сообщений: 433
|
Насчет сбора данных на вновь создаваемый лист вопрос снимается. Убрал из кода
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) Теперь данные собираются на активный лист. Но насчет правой руки и левого уха вопрос остается. |
10.04.2012, 09:46 | #3 |
Старожил
Регистрация: 08.02.2012
Сообщений: 2,173
|
Код:
Правильно поставленная задача - три четверти решения.
|
10.04.2012, 14:32 | #4 |
Форумчанин
Регистрация: 24.01.2011
Сообщений: 136
|
Может Вам эта тема поможет:
http://www.programmersforum.ru/showt...157#post814157 |
10.04.2012, 19:18 | #5 | |
Форумчанин
Регистрация: 21.10.2011
Сообщений: 433
|
Цитата:
|
|
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Печать нескольких листов в один pdf | tae1980 | Microsoft Office Excel | 24 | 26.02.2012 19:37 |
автоматический перенос данных с нескольких листов в один | Наталья Матвеева | Помощь студентам | 0 | 20.02.2012 12:50 |
Объединение данных с нескольких листов в один | Clockgen | Microsoft Office Excel | 10 | 03.11.2010 06:36 |
сбор значений с листов в один | Lyova | Microsoft Office Excel | 5 | 21.01.2009 16:42 |