Страница 1 из 1
Сведение файлов в один список
Добавлено: 06 апр 2009, 10:54
anermo
Привет, помогите чайнику!
Требуется свести много файлов из папки в один. Причем в каждом файлике на одинаковых листах (Sheet1) в одних и тех же ячейках (A4:CL4) в одну строку есть данные, которые надо внести строчка под строчкой в финальный файл.
Re: Сведение файлов в один список
Добавлено: 06 апр 2009, 12:41
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
Re: Сведение файлов в один список
Добавлено: 06 апр 2009, 17:05
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 ячеек, не прописывать же каждую..
Re: Сведение файлов в один список
Добавлено: 06 апр 2009, 18:49
mc-black
Мой пример вставляет строчку шириной 90 столбцов. Код полностью рабочий - я проверял. Тебе надо изменить только одну строку:
Код: Выделить всё
strBook = Dir(ThisWorkbook.Path & "\MyData\*.xls")
или что-то вроде того, можно просто:
Главное, чтобы все эти файлы перед началом обработки были закрыты и файл с макросом также не обрабатывался бы кодом - иначе возникает ошибка при повторном открытии ранее открытого документа.
Re: Сведение файлов в один список
Добавлено: 07 апр 2009, 16:32
anermo
Вставила ссылку, запускаю, и ничего..
Re: Сведение файлов в один список
Добавлено: 07 апр 2009, 23:57
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
Или выкладывай свой код.
Re: Сведение файлов в один список
Добавлено: 13 апр 2009, 11:12
anermo
Работает, спасибо огромное!!
