Сведение файлов в один список

[anermo]

Привет, помогите чайнику!
Требуется свести много файлов из папки в один. Причем в каждом файлике на одинаковых листах (Sheet1) в одних и тех же ячейках (A4:CL4) в одну строку есть данные, которые надо внести строчка под строчкой в финальный файл.

[mc-black]

Нужен критерий, по которому можно перечислить все файлы с данными: либо только они лежат в определенной папке, либо имеют что-то общее в имени, либо на листе Excel есть список с полными путями к файлам с данными. Уточните пожалуйста.
--------------------------------------------------------------------------------
Добавленное сообщение
--------------------------------------------------------------------------------
Это на случай "похожих" названий книг с данными, которые находятся в одной директории с файлом, в который сводится вся информация.

Код: Выделить всё

Sub Main()
    Dim strBook As String
    Dim wrkBook As Workbook
    Dim i As Integer
    
    i = 4
    strBook = Dir(ThisWorkbook.Path & "\Книга*.xls")
    Do While strBook <> ""
        Set wrkBook = Workbooks.Open(ThisWorkbook.Path & "\" & strBook, False, True)
        
        wrkBook.Worksheets(1).Range(Cells(4, 1), Cells(4, 90)).Copy _
                                            ThisWorkbook.Worksheets(1).Cells(i, 1)
        
        wrkBook.Close False
        i = i + 1
        strBook = Dir()
    Loop
    
    Set wrkBook = Nothing
End Sub

[anermo]

Критерий-нахождение в одной папке. То есть надо пробежать все файлы из указанной папки и собрать из каждого инфу.

Я так понимаю, что выглядеть должно примерно так:

Dim myPath As String, myName As String, ws As Worksheet, r As Long
With ThisWorkbook.Sheets(1)
myName = Dir(myPath & "*.xls", vbNormal + vbArchive)
Do While myName <> "папка"
If myName <> ThisWorkbook.Name Then
Workbooks.Open (myPath & myName)
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "Rate" Then
r = .Cells(Rows.Count, "A").End(xlUp).Row + 1

.Cells(r, "A") = ws.[A4]:
.Cells(r, "B") = ws.[B4]:

End If
Next
ActiveWorkbook.Close False
myName = Dir
End If
Loop
End With

НО мне нужно, чтобы вставлялась не ячейка, а сразу область А4:CL4 или строка. Так как у меня там 90 ячеек, не прописывать же каждую..

[mc-black]

Мой пример вставляет строчку шириной 90 столбцов. Код полностью рабочий - я проверял. Тебе надо изменить только одну строку:

Код: Выделить всё

strBook = Dir(ThisWorkbook.Path & "\MyData\*.xls")

или что-то вроде того, можно просто:

Код: Выделить всё

strBook = Dir("C:\MyData\*.xls")

Главное, чтобы все эти файлы перед началом обработки были закрыты и файл с макросом также не обрабатывался бы кодом - иначе возникает ошибка при повторном открытии ранее открытого документа.

[anermo]

Вставила ссылку, запускаю, и ничего..

[mc-black]

Код: Выделить всё

Sub Main()
    Dim strBook As String
    Dim wrkBook As Workbook
    Dim i As Integer
    
    i = 4
    strBook = Dir("C:\MyData\*.xls")
    Do While strBook <> ""
        Set wrkBook = Workbooks.Open(ThisWorkbook.Path & "\" & strBook, False, True)
        
        wrkBook.Worksheets(1).Range(Cells(4, 1), Cells(4, 90)).Copy _
                                            ThisWorkbook.Worksheets(1).Cells(i, 1)
        
        wrkBook.Close False
        i = i + 1
        strBook = Dir()
    Loop
    
    Set wrkBook = Nothing
End Sub

Проверяй: файлы с данными должны лежать в папке C:\MyData
Или выкладывай свой код.

[anermo]

Работает, спасибо огромное!!