Сбор данных из нескольких листов на один с удалением дубликатов, но суммированием значений

[strannick]

Доброй ночи, уважаемые форумчане!
Такая вот задачка: есть периодически поступающие данные в разных книгах (в примере во вложении привел на листе 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 по всем наименованиям формулой СУММЕСЛИ. В принципе, все работает. Но, во-первых вопрос с вновь создаваемым листом (писал выше). Тогда куда будет ссылаться формула? А во-вторых, понимаю, что правой рукой чешу левое ухо. По большому счету, после первого объединения таблица должна просто обновляться, то есть добавляться вновь появившиеся строки )наименования) и добавляться все столбцы с конца. Тогда и суммирование можно производить в автомате в начале таблицы, например в столбцах В и С.

Что скажете по этому поводу? Заранее спасибо.

[strannick]

Насчет сбора данных на вновь создаваемый лист вопрос снимается. Убрал из кода

ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)

Теперь данные собираются на активный лист. Но насчет правой руки и левого уха вопрос остается.

[DiemonStar]

Set R = Range(Sheets("Лист1").Cells("А1"),Sheets("Лист1").Cells("B100"))
R.Copy Sheets("Результат").Cells("A100")

Вот так неплохо копирует диапазоны...

[Djeki]

Может Вам эта тема поможет:
http://www.programmersforum.ru/showt...157#post814157

[strannick]

Сообщение от Djeki

Может Вам эта тема поможет:
http://www.programmersforum.ru/showt...157#post814157

Землякам привет!!! Спасибо за ссылочку, буду разбираться ))))))))))