Просмотр каталога

[kuznetsovSergey]

Доброе утро, уважаемые единомышенники
Хочу обратиться к вам за помощью. Не мгу придумать алгоритм. Суть :

Макрос в Excel, при нажатии кнопки, должен проглядеть весь каталог. В этом каталоге. много Excel книг, одинаковой структуру. Одинаковые названия листов, в общем много листов, в разных папках. но одинаковой структуы, только разные данные внутри.

Необходимо просмотреть все файлы, в каталоге, с вложенными папками, и выцеплять от туда данные, их определенных ячеек. Файлов около 2000.

Макрос. должен брать данные из определенной ячейке, в каждом файле. И построить список эти значений.

На сколько мне известно, есть функция VBA, которая мониторит все вложенные файлы, в каталоге.

ЗАРАНЕЕ СПАСИБО !!

[EducatedFool]

есть функция VBA, которая мониторит все вложенные файлы, в каталоге.

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

Пример кода для работы с файлами из одной папки можно глянуть здесь.

А вот пример для обработки всех файлов Excel из заданной папки:

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

Public FileNames As Collection

Sub Main()
    On Error Resume Next
    ' оставьте одну из следующих двух строк:
    ПутьКПапкеСФайлами = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")    ' там же, где и этот файл
    ПутьКПапкеСФайлами = "D:\Проекты"    ' конкретная папка

    Set FileNames = New Collection: On Error Resume Next
    Call ReadFileNames(ПутьКПапкеСФайлами)    ' поиск подходящих файлов во всех подпапках

    For Each file In FileNames
        Debug.Print file
        ' ОбработкаФайла file
    Next
End Sub


Function ReadFileNames(ByVal FolderPath As String)
    Set fso = CreateObject("scripting.filesystemobject")
    Set curfold = fso.GetFolder(FolderPath)

    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            If fil.Path Like "*.xls*" Then FileNames.Add fil.Path
        Next
        For Each sfol In curfold.SubFolders
            ReadFileNames sfol.Path
        Next
        Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:
    End If
End Function

[mc-black]

Можно рекурсию перебора папок сделать на одной только Dir. Правда для рекурсии она не приспособлена, поэтому сначала перебор содержимого папки с формированием в динамическом массиве списка подпапок, а потом развертывание в цикле из массива непосредственно рекурсивных вызовов. Если интересно, могу восстановить по памяти код. Также есть классический перебор папок тремя API: FindFirstFile, FindNextFile, FindClose.

[kuznetsovSergey]

Можно рекурсию перебора папок сделать на одной только Dir. Правда для рекурсии она не приспособлена, поэтому сначала перебор содержимого папки с формированием в динамическом массиве списка подпапок, а потом развертывание в цикле из массива непосредственно рекурсивных вызовов. Если интересно, могу восстановить по памяти код. Также есть классический перебор папок тремя API: FindFirstFile, FindNextFile, FindClose.

был бы очень признателен, если выложите пример. Очень облегчило бы в дальнейшем мне все проблемы =)

[kuznetsovSergey]

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

Пример кода для работы с файлами из одной папки можно глянуть здесь.

А вот пример для обработки всех файлов Excel из заданной папки:

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

Public FileNames As Collection
 
Sub Main()
On Error Resume Next
' оставьте одну из следующих двух строк:
ПутьКПапкеСФайлами = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "") ' там же, где и этот файл
ПутьКПапкеСФайлами = "D:\Проекты" ' конкретная папка
 
Set FileNames = New Collection: On Error Resume Next
Call ReadFileNames(ПутьКПапкеСФайлами) ' поиск подходящих файлов во всех подпапках
 
For Each file In FileNames
Debug.Print file
' ОбработкаФайла file
Next
End Sub
 
 
Function ReadFileNames(ByVal FolderPath As String)
Set fso = CreateObject("scripting.filesystemobject")
Set curfold = fso.GetFolder(FolderPath)
 
If Not curfold Is Nothing Then
For Each fil In curfold.Files
If fil.Path Like "*.xls*" Then FileNames.Add fil.Path
Next
For Each sfol In curfold.SubFolders
ReadFileNames sfol.Path
Next
Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:
End If
End Function

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

[mc-black]

Классика жанра с Win32 API (выдрано из одного моего проекта, в отрыве от проекта не тестировалось):

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

Option Explicit

Private Const MAX_PATH = 260

Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Boolean
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Boolean

Private Sub WorkWithFile(SourceDir As String, FileName As String)
    ' Здесь работаем с файлами
End Sub

Private Sub RecursiveSubprogram(Source As String)
    Dim objName As String
    Dim hSearch As Long
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Boolean

    Cont = True
    hSearch = FindFirstFile(Source & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        Do While Cont
            objName = Left(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
            If Not (objName = "." Or objName = "..") Then
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = 0 Then
                    Call WorkWithFile(Source, objName)
                Else
                    RecursiveSubprogram Source & objName & "\"
                End If
            End If
           Cont = FindNextFile(hSearch, WFD)
        Loop
        Cont = FindClose(hSearch)
    End If
End Sub

Function TestRecursiveEnumerate()
    'Отсюда начинаем рекурсию
    RecursiveSubprogram "C:\Folder1\"
End Function

[mc-black]

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

Здесь главная ключевая особенность рекурсии: ниличие внутри подпрограммы (функции, процедуры) вызовов самой себя с изначальным запуском извне этой подпрограммы. Мы запускаем подпрограмму однажды, а она в свою очередь вызывает себя еще несколько раз до тех пор, пока не наступит условие, при котором подпрограмма не перестанет вызывать саму себя (иначе действительно бесконечный цикл).

С функцией Dir этот номер не проходит, т.к. она не может работать изолированно в нескольких разных вызовах рекурсии, поскольку использует (и может менять) одну и ту же текущую директорию. Есть способ обмануть ее, я как-нибудь напишу пример, сегодня нет времени.

[kuznetsovSergey]

Необходимость о данной просьбе исчерпана. Нашёл более легкий путь, который устроил всех.
Но всё же прошу привести пример решение проблемы, для саморазвития.
СПАСИБО ЗАРАНЕЕ

[mc-black]

То, что и обещал, исключительно встроенными средствами VBA:

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

Option Explicit

Sub Test()
    Call RecursiveEnumerator("C:\prog\vba\")
End Sub

Sub RecursiveEnumerator(MyPath As String)
    Dim MyName As String, SubDir() As String, i As Long
    
    ReDim SubDir(0 To 0) As String
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
                i = UBound(SubDir) + 1
                ReDim Preserve SubDir(0 To i) As String
                SubDir(i) = MyPath & MyName & "\"
            Else
                Call FilePrecessing(MyPath, MyName)
            End If
        End If
        MyName = Dir
    Loop
    
    i = 1
    Do While i <= UBound(SubDir)
        Call RecursiveEnumerator(SubDir(i))
        i = i + 1
    Loop
End Sub

Sub FilePrecessing(Directory As String, FileName As String)
    Debug.Print Directory & FileName
End Sub

Восстановил пример по памяти. Sub Test() содержит пример запуска первого вызова рекурсивной подпрограммы. Sub RecursiveEnumerator(MyPath As String) - сама рекурсивная процедура - содержит вызов самой из себя в 4-й от конца считать строчке. FilePrecessing(Directory As String, FileName As String) - пример процедуры, куда можно вложить всю логику программы по обработке каждого найденного файла.

[kuznetsovSergey]

То, что и обещал, исключительно встроенными средствами VBA:

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

Option Explicit

Sub Test()
Call RecursiveEnumerator("C:\prog\vba\")
End Sub

Sub RecursiveEnumerator(MyPath As String)
Dim MyName As String, SubDir() As String, i As Long

ReDim SubDir(0 To 0) As String
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
i = UBound(SubDir) + 1
ReDim Preserve SubDir(0 To i) As String
SubDir(i) = MyPath & MyName & "\"
Else
Call FilePrecessing(MyPath, MyName)
End If
End If
MyName = Dir
Loop

i = 1
Do While i <= UBound(SubDir)
Call RecursiveEnumerator(SubDir(i))
i = i + 1
Loop
End Sub

Sub FilePrecessing(Directory As String, FileName As String)
Debug.Print Directory & FileName
End Sub

Восстановил пример по памяти. Sub Test() содержит пример запуска первого вызова рекурсивной подпрограммы. Sub RecursiveEnumerator(MyPath As String) - сама рекурсивная процедура - содержит вызов самой из себя в 4-й от конца считать строчке. FilePrecessing(Directory As String, FileName As String) - пример процедуры, куда можно вложить всю логику программы по обработке каждого найденного файла.

Поражает воображение ! спасибо за исчерпывающий вариант, наконец то дорос понять этот код ) и он меня поразил ! СПАСИБО ОГРОМНОЕ !