Перебрать файлы в папке и скинуть ссылку на них в массив.

[erzhavin]

Народ, помогите пожалуйста!
Хочу организовать цикл по файлам ( все из одной директории!) для создания сводного отчета в Excel.
Отчет будет заключаться в простом сведении некоторых ячеек из каждого из 40-ка файлов.
Собственно вопрос:
1) Чтобы брать данные из файлов (их около 40 в папке лежит) нужно ли их открывать, то есть добавлять в проект?
2) Как организовать цикл по файлам? То есть хотелось бы чтобы пользователь сам мог выбрать файлы, для вхождения в отчет.
Эти ссылки на файлы должны записываться в динамический массив а потом по нему делать цикл? Так?
Спасибо, если кто ответит, очень нужна помощь.

[a_mayor]

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

Private Sub Workbook_Open()
    Dim szDir As String
   
   
   
    szDir = Dir(ThisWorkbook.Path & "\", vbDirectory)
   
    While szDir <> ""
        If szDir <> "" And szDir <> "." And szDir <> ".." Then
            If LCase(Right(szDir, 4)) = ".xls" Then
                With Sheet1
                    .Hyperlinks.Add .Range("A" & WorksheetFunction.CountA(.Range("A:A")) + 1), ThisWorkbook.Path & "\" & szDir
                End With
            End If
        End If
       
        szDir = Dir
    Wend
End Sub


[alibek]

Он не это спрашивает.
Ему надо свести в одном листе данные из нескольких файлов.

[a_mayor]

организовать цикл по файлам? То есть хотелось бы чтобы пользователь сам мог выбрать файлы, для вхождения в отчет.

[alibek]

организовать цикл по файлам? То есть хотелось бы чтобы пользователь сам мог выбрать файлы, для вхождения в отчет.

Т.е. есть список файлов с чекбоксами, пользователь отмечает нужные файлы, переходит на лист "Сводка" и там показываются данные по выбранным файлам.

[erzhavin]

Мне нужно из 40 файлов создать один!
Так вот, я не знаю сам принцип того, как это сделать!
У меня идея такая
1) Сначала сделать функцию которая записывает массив из адресов файлов, выбранных пользователем.
2) Затем создать новый файл
3) Потом организовать цикл по выбранным файлам, просматривать каждый,
вырезать из него кусок и вставлять в новый файл, поочереди к нему обращаясь (а точнее 40 раз!)/ мне кажется это неверно...
Правильно ли я мыслю? Нужно ли по очереди открывать все файлы или просто сделать на него ссылку типа set...Можно ли делать это все в одной процедуре?

Вот функция по записи адресов файлов в массив:

Function FillingFilesPathArray()
Dim n As Integer
Dim lngCount As Long
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
n = .SelectedItems.Count
Dim arr() As String
ReDim arr(n)
arr(n) = .SelectedItems(lngCount)
'Debug.Print arr(n)
Next lngCount
End With
FillingFilesPathArray = arr()
End Function

[alibek]

Я бы просто использовал формулы с ссылками на другие листи. Это было бы правильнее.

[erzhavin]

Нет, ну там просто формулами не обойтись...Ну что - неправильно я думаю?

[alibek]

Формулы создаются кодом.

[erzhavin]

Народ, я щас точно умру от своей тупости. У меня есть функция(написана наверху), которая возвращает массив из адресов файлов.
Как передать этот массив в процедуру и создать по нему цикл??? Что то я туплю...

[Al Khamid]

...

[erzhavin]

Это ясно что можно делать через ссылки на другие файлы при условии того, что данные одни и те же и их просто нужно складывать или что-то делать типа этого! А когда надо сделать совершенно другой файл, в котором другое форматирование, в котором переменное количество столбцов, строк и так далее? Вопрос в следующем - можно ли обратиться к файлу программно и брать из него данные(наверное даже изменять) не открывая его? А то 40 самооткрывающихся файлов для пользователя как-то неожиданно будет! То есть у меня вот так щас:

Sub PereborFailov()
Dim lngCount As Long
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
For lngCount = 1 To .SelectedItems.Count
Debug.Print .SelectedItems(lngCount)
Path = .SelectedItems(lngCount)
Set CurrentBook = Workbooks.Add(Path)

' !!! Здеся будет обработка файлов

Next lngCount
End With
End Sub

Этот код открывает все выбранные файлы черт возьми!

[Al Khamid]

>>>

[shyrik_m]

У меня вставала подобная задача.

Собрать файлы можно так (в моем случае на лист)

Sub Просмотреть_папку()


With Application.FileSearch
.NewSearch
.LookIn = "D:\Твои документы"
.SearchSubFolders = False
.Filename = ".xls"
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then

'MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
Cells(i + 2, 1) = Mid(.FoundFiles(i), 18)
Next i

Else
MsgBox "Нет файлов."
End If
End With
End Sub

Вот, теперь список файлов есть, если тебя не устраивает лист, то делай массив.

[shyrik_m]

В следующем примере макрос копирует таблицы из этих файлов, с заданных листов в тот файл, в котором находится макрос, разберешся
вместо списка файлов на листе можеш обращаться к своему массиву

Sub Поиск()
R = ActiveCell.Row
ИСКОМОЕ = ActiveSheet.TextBox1
Range("b3:b60000").Find(What:=ИСКОМОЕ, After:=Cells(R, 2), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False).Activate
ActiveCell.Rows("1:1").EntireRow.Select
End Sub
Sub Открыть_и_разнести()
Dim Дата As Long
Dim ИСКОМОЕ As Variant
Selection.AutoFilter Field:=1
Дата = Cells(1, 2)
мес = Workbooks("Открывашка.xls").Sheets("Файлы разноски").Cells(2, 2)
x = ActiveCell.Row '_______строка искомой ячейки
Cells(x, 2).Select
ИСКОМОЕ = ActiveCell

Range("b2:b60000").Find(What:="Файл", After:=Cells(x, 2), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Activate

ActiveCell.Rows("1:1").EntireRow.Select

Dim имя_файла As Variant
g = ActiveCell.Row '_______строка вычитаемой ячейки
ОткрываемыйФайл = ActiveCell

'1. !!! !!! !!! !!! Внести изменения:

имя_файла = "D:\Мои документы\000 Разноска\" & Cells(g, 1)
Workbooks.OpenText Filename:=имя_файла
Sheets(мес).Select '00000000000000000000
'Range("b2:b60000").Find(What:=ИСКОМОЕ, After:=Cells(4, 2), LookIn:=xlValues, LookAt:= _
' xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
' False).Activate
Cells(x - g + 3, 2).Select
ActiveCell.Rows("1:1").EntireRow.Select

rr = ActiveCell.Row
ss = Cells(rr, Дата + 6)

Cells(rr, Дата + 6) = ss + 1

SaveChanges = True
ActiveWindow.Close SaveChanges = True
Cells(x, 2).Select

'Сдераем отметку в Открывашке
rr = ActiveCell.Row
ss = Cells(rr, Дата + 6)
Cells(rr, Дата + 6) = ss + 1
End Sub
Sub Открыть_файл_разноски_из_Данных()
a = Cells(1, 2)
Dim ИСКОМОЕ As Variant
Selection.AutoFilter Field:=1

x = ActiveCell.Row
Cells(x, 2).Select
ИСКОМОЕ = ActiveCell

Range("b2:b60000").Find(What:="Файл", After:=Cells(x, 2), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Activate

ActiveCell.Rows("1:1").EntireRow.Select

Dim имя_файла As Variant
g = ActiveCell.Row
Cells(x, 2).Select

'2. !!! !!! !!! !!! Внести изменения:

имя_файла = "D:\Мои документы\000 Разноска\" & Cells(g, 1)

Workbooks.OpenText Filename:=имя_файла
Cells(1, 2) = a
Range("b2:b60000").Find(What:=ИСКОМОЕ, After:=Cells(4, 2), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Activate
ActiveCell.Rows("1:1").EntireRow.Select

End Sub
Sub ЧГН()
Application.ScreenUpdating = False 'Отключаем обновление экрана

Dim мес, pyt, awn, a, ЛисТ, AArow
Dim STROCHKA As Integer
STROCHKA = 2
мес = Workbooks("Открывашка.xls").Sheets("Файлы разноски").Cells(2, 2)
'3. !!! !!! !!! !!! Внести изменения:

pyt = "D:\Мои документы\000 Разноска\"
Windows("Открывашка.xls").Activate

Sheets("Подложка").Visible = True
Sheets("Подложка").Select
Sheets("Подложка").Copy After:=Sheets(1)
Sheets("Подложка (2)").Select
Sheets("Подложка (2)").Name = "Данные"
Sheets("Подложка").Visible = False

Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Контролька"

Dim JIM As Integer
'0000000000000000 Workbooks("Открывашка.xls").Sheets("Файлы разноски").Cells(JIM, 1)
JIM = 3
Do Until IsEmpty(Workbooks("Открывашка.xls").Sheets("Файлы разноски").Cells(JIM, 1))
'Do Until IsEmpty(Cells(JIM, 1))

Workbooks.Open Filename:=pyt & Workbooks("Открывашка.xls").Sheets("Файлы разноски").Cells(JIM, 1)

Sheets(мес).Select
awn = ActiveWorkbook.Name

'000000000000000000000000000000000000000000000000000000000000000000000000000

a = КолПолнСтрок'моя функция определяющая номер последней строки "разорванного" списка

'000000000000000000000000000000000000000000000000000000000000000000000000000

Range(Cells(4, 1), Cells(a, 50)).Select

Selection.Copy
ЛисТ = ActiveSheet.Name

Windows("Открывашка.xls").Activate
'Sheets("Контролька").Select
Workbooks("Открывашка.xls").Sheets("Контролька").Cells(JIM - 2, 1) = ЛисТ '00000000000000000
Sheets("Данные").Select
'__________________
Cells(STROCHKA, 1).Select
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
STROCHKA = STROCHKA + a
'___________________
ActiveCell.Select 'Выделена строка для названия файла
ActiveCell = awn
AArow = ActiveCell.Row
Cells(AArow, 2) = "Файл" 'Вставка слова "файл"
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
ActiveCell.Select

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

Workbooks(awn).Close SaveChanges:=False
JIM = JIM + 1
'Sheets("Файлы разноски").Select
Loop

Sheets("Данные").Select
Cells(STROCHKA + 1, 2) = "Файл"
Sheets("Контролька").Select
ActiveSheet.Name = "Контролька " & Day(Now) & "." & Month(Now) & "-" & Hour(Time) & "." & Minute(Time) & "." & Second(Time)

Sheets("Данные").Select
ActiveSheet.Name = "Данные " & Day(Now) & "." & Month(Now) & "-" & Hour(Time) & "." & Minute(Time) & "." & Second(Time)

'Закрепляем области окна
Range("G3").Select
ActiveWindow.FreezePanes = True

' Фильтр
Cells(3, 6) = 1
Cells(2, 6) = 1

Range(Cells(2, 6), Cells(STROCHKA, 6)).Select
Selection.AutoFilter
Range("F2").Select

'Кнопка для сброса фильтра
ActiveSheet.Buttons.Add(195.75, 3, 91.5, 11.5).Select
Selection.OnAction = "СбросФильтр"
Selection.Characters.Text = "СбросФильтр"

'Кнопка для открытия файла
ActiveSheet.Buttons.Add(105.75, 3.75, 78, 17.25).Select
Selection.OnAction = "Открыть_файл_разноски_из_Данных"
Selection.ShapeRange.AlternativeText = "Открыть"

Selection.Characters.Text = "Открыть"

'Расставим даты
Cells(2, 7) = 1
Cells(2, = 2
Range("G2:AK2").Select
Selection.DataSeries Rowcol:=xlRows, Type:=xlLinear, Date:=xlDay, Step _
:=1, Trend:=False

'Автоподбор ширины столбцов
Columns("A:AO").Columns.AutoFit
Columns("G:AK").ColumnWidth = 2

'Назначенный подбор ширины столбцов
Columns("A:A").ColumnWidth = 15
Columns("B:B").ColumnWidth = 15
Columns("C:C").ColumnWidth = 4
Columns("D:D").ColumnWidth = 4
Columns("E:E").ColumnWidth = 9
Columns("F:F").ColumnWidth = 9

'Надпись: Дата
Cells(1, 1) = "Число"
Cells(1, 2) = Day(Date - 1)

Rows("2:2").RowHeight = 23

'Кнопка для открытия файла и отметки о реализации
ActiveSheet.Buttons.Add(96.25, 1.5, 57, 21.75).Select
Selection.OnAction = "Открыть_и_разнести"
Selection.Characters.Text = "Разнести"

'Кнопка и поле для поиска
ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=1.5, Top:=13.5, Width:=41.25, Height:= _
11.25).Select
Selection.ShapeRange.ScaleHeight 1.4, msoFalse, msoScaleFromTopLeft

ActiveSheet.Buttons.Add(43.5, 12.75, 39, 12.75).Select
Selection.OnAction = "Поиск"
Selection.Characters.Text = "Поиск"
'_____________

ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=246, Top:=17.25, Width:=44.25, Height:= _
16.5).Select
ActiveSheet.Buttons.Add(294, 17.25, 35.25, 15).Select
Selection.OnAction = "Фильтр_цен"
Selection.Characters.Text = ""

ActiveSheet.Buttons.Add(94.5, 18.75, 60, 15).Select
Selection.OnAction = "Открыть_и_разнести_всё"
Selection.Characters.Text = "Разнести всё"

ActiveSheet.Buttons.Add(174.75, 22.5, 39.75, 12.75).Select
Selection.OnAction = "Открыть_и_добавить_единицу_в_приход"
Selection.Characters.Text = "+1"

'______________
'Условное форматирование
Range("C3").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=C3+D3-СУММ(G3:AK3)<=0"
Selection.FormatConditions(1).Interior.ColorIndex = 46

Selection.Copy

Range(Cells(3, 3), Cells(STROCHKA, 3)).Select

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Rows("1:2").Interior.ColorIndex = 6

Application.CutCopyMode = False

Application.ScreenUpdating = True 'Включаем обновление экрана

End Sub
Sub Открыть_и_добавить_единицу_в_приход()

Dim Дата As Long
'Dim ИСКОМОЕ As Variant
Selection.AutoFilter Field:=1

мес = Workbooks("Открывашка.xls").Sheets("Файлы разноски").Cells(2, 2)
x = ActiveCell.Row '_______строка искомой ячейки
Cells(x, 2).Select
'ИСКОМОЕ = ActiveCell

Range("b2:b60000").Find(What:="Файл", After:=Cells(x, 2), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Activate

ActiveCell.Rows("1:1").EntireRow.Select


Dim имя_файла As Variant
g = ActiveCell.Row '_______строка вычитаемой ячейки
ОткрываемыйФайл = ActiveCell

'1. !!! !!! !!! !!! Внести изменения:

имя_файла = "D:\Мои документы\000 Разноска\" & Cells(g, 1)
Workbooks.OpenText Filename:=имя_файла
Sheets(мес).Select '00000000000000000000
'Range("b2:b60000").Find(What:=ИСКОМОЕ, After:=Cells(4, 2), LookIn:=xlValues, LookAt:= _
' xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
' False).Activate
Cells(x - g + 3, 2).Select
ActiveCell.Rows("1:1").EntireRow.Select


Cells(ActiveCell.Row, 4) = Cells(ActiveCell.Row, 4) + 1

SaveChanges = True
ActiveWindow.Close SaveChanges = True
Cells(x, 2).Select

'Сдераем отметку в Открывашке
Cells(ActiveCell.Row, 4) = Cells(ActiveCell.Row, 4) + 1

End Sub

Вот такой код

[shyrik_m]

Этот пример делает нужные вычисления на листе каждой книги и выдает результаты в файле с данным макросом

Public Sub ImportRealizatcii()
'Собирает данные о реализации
'pyt = "D:\Мои документы\000 Разноска\"
Windows(thisbook).Activate
Application.ScreenUpdating = False 'Отключаем обновление экрана

Dim JJJ As Integer
JJJ = 3
Do Until IsEmpty(Cells(JJJ, 1))
If Cells(JJJ, 1) = 1 Then GoTo QQQ
Call ActivateFile(foldRazn, Cells(JJJ, 1))'Открывает файл или активирует, если файл открыт
Sheets("Июнь 2005").Select 'Ввести название обрабатываемой страницы
awn = ActiveWorkbook.Name
asn = ActiveSheet.Name
'too = Cells(1, 39)
'tor = Cells(1, 40)


a = KolStr() 'Определение_занятых_строк

ddd = FindError(a) 'Функция "Исправление ошибок"

r = 4
'X = 0
'Y = 0
too = 0
tor = 0

Do While r <= a
'X = X + (Cells(R, 3) * Cells(R, 5))
'Y = Y + (Cells(R, 3) * Cells(R, 6))
too = too + Application.WorksheetFunction.Sum(Cells(r, 7), Cells(r, 37)) * Cells(r, 5)
tor = tor + Application.WorksheetFunction.Sum(Cells(r, 7), Cells(r, 37)) * Cells(r, 6)
r = r + 1
Loop

Windows(thisbook).Activate
Application.ScreenUpdating = True 'Включаем обновление экрана

Cells(JJJ, 3) = asn
Cells(JJJ, 4) = too
Cells(JJJ, 5) = tor
'Cells(JJJ, 7) = X
'Cells(JJJ, = Y
Application.ScreenUpdating = False 'Отключаем обновление экрана

Workbooks(awn).Close SaveChanges = False

QQQ:
ЫЫЫ = JJJ - 15
If ЫЫЫ > 2 Then ActiveWindow.ScrollRow = ЫЫЫ
JJJ = JJJ + 1
Loop
End Sub

[shyrik_m]

Могу подбросить пример с сортировкой данных