Обьединение листов из закрытых книг

[Extril]

Здравствуйте, понимаю, что тема избита, но ни одного решения подходящего под мои условия я не нашел на просторах форумов, именно поэтому прошу Вашего участия
Дано:
множество файлов разного наименования (например "книга 1", "книга 2"), в которых одинаковые листы по наименованию и структуре (лист1, лист 2, лист 3), все файлы в одной папке temp
Что нужно:
обьединить содержимое листов "лист 2" всех книг на лист 2 книги 3
Условие:
Действие выполняется с условием, что при наличии в листе 2 книги 3копируемых данных, добавляются только новые.

[kuklp]

Если что, стол заказов здесь:
http://www.programmersforum.ru/forum...sprune=-1&f=29

[Extril]

Спасибо, в таком случае этот раздел стоит перенести в раздел фриланс.

[kuklp]

Почему? Здесь безвозмездно помогают. Особенно тем, кто сам что-то делает. А заказы да, во фриланс.

[Extril]

Форумчане мне помогли с циклом:

Private Sub CommandButton2_Click()
Dim x As Range, ws As Worksheet, p As String
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set ws = Sheets("Лист 2"): Set x = ws.[C4:N25]: x.ClearContents
Sheets.Add.Name = "tmp": p = ThisWorkbook.Path & "\"
For Each f In Array("Книга 1.xlsx", "Книга 2.xlsx")
With ActiveSheet.Range(x.Address)
.ClearContents
.Formula = "='" & p & "[" & f & "]Лист 2'!" & x.Address
.Copy
x.PasteSpecial Paste:=xlPasteValues
End With
Next
ActiveSheet.Delete: x.Value = x.Value: [C15:N15].Value = [C3:N3].Value: [A1].Select
End Sub

Но, как я вижу здесь речь идет о копировании и вставке, вопрос в том, что бы вставить последовательно, все содержимое копируемых листов

[SAS888]

Действие выполняется с условием, что при наличии в листе 2 книги 3 копируемых данных, добавляются только новые.

1. Что есть "новые" данные? Проверять на совпадение все ячейки строки? Или достаточно проверить по какому-то (каким-то) конкретному столбцу?
2. Известен ли диапазон ячеек для копирования? Или, хотя бы максимальное количество строк и столбцов в файлах-источниках?

[Extril]

Доброе утро, подразумевается, что :
1. Проверять на совпадение (заполненнение) в диапазоне A1:A100, и при появление новой заполненной ячейки, которой нет в консолидированной книге Книга 3, добавлять к существующим в ней записям
2. Диапазон копирования A1:i100 (часть строй пустая, поскольку заполнение происходит ежедневно), поэтому копировать необходимо только заполненные строки, как фильтр для проверки ячейка A1

[SAS888]

Чтобы не тратить время зря, давайте уточним:
1. Книга, в которую собираем данные называется "Книга3", а лист этой книги, на который собираем данные, называется "Лист2". Так?
2. Где находится папка с файлами, из которых требуется получить новые данные? Необходимо либо знать полный путь (прописав его в макросе), либо выбирать папку в диалоговом окне.
3. Из каждой книги в папке "temp" берем данные из листа "Лист2" в диапазоне "A1:I100", проверяем на совпадение с имеющимися данными по столбцу "A" и если такого значения нет, то добавляем эти строки к имеющимся. Так?

[Extril]

Спасибо большое за участие, относительно вопросов
1. Все верно, книга, в которую собираем данные называется "Книга3", а лист этой книги, на который собираем данные, называется "Лист2".
2. папка с файлами, из которых требуется получить новые данные находится по адресу с:\temp
3. Из каждой книги в папке "temp" берем данные из листа "Лист2" в диапазоне "A1:I100" проверяем на совпадение с имеющимися данными по столбцу "D" и если такого значения нет, то добавляем все новые строки к имеющимся.

[SAS888]

Лучше, примерно, так, ибо при больших объемах формулы будут сильно тормозить процесс:

Sub Main()
    Dim ws As Worksheet, ws1 As Worksheet, i As Integer, j As Integer, k As Integer, p As String, f As String, x, a(), b()
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Sheets("Лист2")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set x = CreateObject("Scripting.Dictionary")
    p = "C:\temp\": f = Dir(p & "*.xls*"): k = 0
    a = ws.Range("D1:D" & ws.Cells(Rows.Count, 4).End(xlUp).Row + 1).Value
    For i = 1 To UBound(a, 1)
        If Not x.Exists(a(i, 1)) Then x.Add a(i, 1), a(i, 1)
    Next
    ReDim b(1 To fso.GetFolder(p).Files.Count * 100, 1 To 9)
    Do While f <> ""
        Set ws1 = GetObject(p & f).Worksheets("Лист2")
        a = ws1.Range("A1:I100").Value
        For i = 1 To UBound(a, 1)
            If a(i, 4) <> "" And a(i, 4) <> 0 Then
                If Not x.Exists(a(i, 4)) Then
                    x.Add a(i, 4), a(i, 4)
                    k = k + 1
                    For j = 1 To UBound(a, 2): b(k, j) = a(i, j): Next
                End If
            End If
        Next
        ws1.Parent.Close (False): f = Dir
    Loop
    If k <> 0 Then ws.Cells(ws.Cells(Rows.Count, 4).End(xlUp).Row + 1, 1).Resize(k, 9).Value = b
    Set x = Nothing
End Sub

ЗАМЕЧАНИЯ:
1. Макрос должен находиться в той книге, в которую требуется собрать данные.
2. Книга с макросом не должна находиться в папке-источнике ("C:\temp").
3. Если имя книги совпадет с именем книги с макросом, или в текущем файле не будет существовать лист с именем "Лист2", то будет ошибка.

Если нужно - вставьте соответствующие проверки, либо укажите, что в этих случаях нужно сделать.