Vba excel поиск по всем файлам - Word и Excel - помощь в работе с программами

Функция FilenamesCollection предназначена для получения списка файлов из папки, с учётом выбранной глубины поиска в подпапках.

Используется рекурсивный перебор папок, до заданного уровня вложенности.
В процессе перебора папок, пути у найденным файлам помещаются в коллекцию (объект типа Collection) для последующего перебора.

К статье прикреплено 2 примера файла с макросами на основе этой функции:

Пример в файле FilenamesCollection.xls выводит список файлов на чистый лист новой книги (формируя заголовки)
Пример в файле FilenamesCollectionEx.xls более функционален — он, помимо списка файлов из папки, отображает размер файла, и дату его создания, а также формирует в ячейках гиперссылки на найденные файлы.
Вывод списка производится на лист запуска, параметры поиска файлов задаются в ячейках листа (см. скриншот)

Смотрите также расширенную версию макроса на базе этой функции:

Макрос FolderStructure выводит в таблицу Excel список файлов и подпапок с отображением структуры (вложенности файлов и подпапок)

ПРИМЕЧАНИЕ: Если вы выводите на лист список имен файлов картинок (изображений), то при помощи этой надстройки вы сможете вставить сами картинки в ячейки соседнего столбца (или в примечания к этим ячейкам)

Внимание: если требуется, чтобы поиск не зависел от регистра символов в маске файла
(к примеру, обнаруживались не только файлы .txt, но и .TXT и .Txt),
поставьте первой строкой в модуле директиву Option Compare Text

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' © EducatedFool  excelvba.ru/code/FilenamesCollection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

‘ Пример использования функции в макросе:

Sub ОбработкаФайловИзПапки()
    On Error Resume Next
    Dim folder$, coll As Collection
 
    folder$ = ThisWorkbook.Path & "Платежи"
    If Dir(folder$, vbDirectory) = "" Then
        MsgBox "Не найдена папка «" & folder$ & "»", vbCritical, "Нет папки ПЛАТЕЖИ"
        Exit Sub        ' выход, если папка не найдена
    End If
 
    Set coll = FilenamesCollection(folder$, "*.xls")        ' получаем список файлов XLS из папки
    If coll.Count = 0 Then
        MsgBox "В папке «" & Split(folder$, "")(UBound(Split(folder$, "")) - 1) & "» нет ни одного подходящего файла!", _
               vbCritical, "Файлы для обработки не найдены"
        Exit Sub        ' выход, если нет файлов
    End If
 
    ' перебираем все найденные файлы
    For Each file In coll
        Debug.Print file        ' выводим имя файла в окно Immediate
    Next
End Sub

Этот код позволяет осуществить поиск нужных файлов в выбранной папке (включая подпапки), и выводит полученный список файлов на лист книги Excel:

Sub ПримерИспользованияФункции_FilenamesCollection()
    ' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён.
    ' Просматриваются папки с глубиной вложения не более трёх.

    Dim coll As Collection, ПутьКПапке As String
    ' получаем путь к папке РАБОЧИЙ СТОЛ
    ПутьКПапке = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке, ".txt", 3)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана
    ' создаём новую книгу
    Dim sh As Worksheet: Set sh = Workbooks.Add.Worksheets(1)
    ' формируем заголовки таблицы
    With sh.Range("a1").Resize(, 3)
        .Value = Array("№", "Имя файла", "Полный путь")
        .Font.Bold = True: .Interior.ColorIndex = 17
    End With
 
    ' выводим результаты на лист
    For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
        sh.Range("a" & sh.Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
        Array(i, Dir(coll(i)), coll(i))    ' выводим на лист очередную строку
        DoEvents    ' временно передаём управление ОС
    Next
    sh.Range("a:c").EntireColumn.AutoFit    ' автоподбор ширины столбцов
    [a2].Activate: ActiveWindow.FreezePanes = True ' закрепляем первую строку листа
End Sub

Ещё один пример использования:

Sub ЗагрузкаСпискаФайлов()
    ' Ищем файлы в заданной папке по заданной маске,
    ' и выводим на лист список их параметров.
    ' Просматриваются папки с заданной глубиной вложения.

    Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%
 
    ПутьКПапке$ = [c1]    ' берём из ячейки c1
    МаскаПоиска$ = [c2]    ' берём из ячейки c2
    ГлубинаПоиска% = Val([c3])    ' берём из ячейки c3
    If ГлубинаПоиска% = 0 Then ГлубинаПоиска% = 999    ' без ограничения по глубине

    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам

        НомерФайла = i
        ПутьКФайлу = coll(i)
        ИмяФайла = Dir(ПутьКФайлу)
        ДатаСоздания = FileDateTime(ПутьКФайлу)
        РазмерФайла = FileLen(ПутьКФайлу)
 
        ' выводим на лист очередную строку
        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(НомерФайла, ИмяФайла, ПутьКФайлу, ДатаСоздания, РазмерФайла)
 
        ' если нужна гиперссылка на файл во втором столбце
        ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
                                   "Открыть файл" & vbNewLine & ИмяФайла
 
        DoEvents    ' временно передаём управление ОС
    Next
End Sub

PS: Найти подходящие имена файлов в коллекции можно при помощи следующей функции:

Function CollectionAutofilter(ByRef coll As Collection, ByVal filter$) As Collection
    ' Функция перебирает все элементы коллекции coll,
    ' оставляя лишь те, которые соответствуют маске filter$ (например, filter$="*некий текст*")
    ' Возвращает коллекцию, содержащую только подходящие элементы
    ' Если элементы не найдены - возвращается пустая коллекция (содержащая 0 элементов)
    On Error Resume Next: Set CollectionAutofilter = New Collection
    For Each Item In coll
        If Item Like filter$ Then CollectionAutofilter.Add Item
    Next
End Function

301791 просмотр

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

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

Источник

Поиск по файлам

scofield

Дата: Понедельник, 28.09.2015, 11:29 |
Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация:
0
±

Замечаний:
0% ±

Excel 2013

Добрый день! Подскажите пожалуйста, где я ошибаюсь. Задача следующаяя: имеются файлы, которые эксель определяет. В этих файлах хранится текстовая информация. В главном файле задается критерий для поиска и кноркой активируется поиск, после чего найденные записи по всем файлам выводятся на лист главного. Но при поиске он ищет почему-то только в самом себе, а не в нужных.

[vba]

Код

Private Sub CommandButton1_Click()
ТекстДляПоиска = «ант»
[c1] = «C:UsersАдминистраторDesktopГУН»
‘ Ищем файлы в заданной папке по заданной маске,
‘ и выводим на лист список их параметров.
‘ Просматриваются папки с заданной глубиной вложения.

Dim coll As Collection, FolderPath$, searchmask$, searchdepth%
On Error Resume Next
FolderPath$ = [c1] ‘ берм из ячейки c1
searchmask$ = «*.*xl*» ‘ берм из ячейки c2
searchdepth% = 1 ‘ берм из ячейки c3
If searchdepth% = 0 Then searchdepth% = 999 ‘ без ограничения по глубине

‘ считываем в колекцию coll нужные имена файлов
Set coll = FilenamesCollection(FolderPath$, searchmask$, searchdepth%)

Application.ScreenUpdating = False ‘ отключаем обновление экрана

‘ выводим результаты (список файлов, и их характеристик) на лист
For i = 1 To coll.Count ‘ перебираем все элементы коллекции, содержащей пути к файлам

filenumber = i
pathtothefile = coll(i)
Filename = Dir(pathtothefile)
creationdate = FileDateTime(pathtothefile)
filesize = FileLen(pathtothefile)
filesize = FileOrFolderSize(filesize)
‘——————————————————————
ТекстДляПоиска = «*» & «ант» & «*»
Set СписокНомеровНайденныхСтрок = New Collection
On Error Resume Next ‘ отключаем останов при ошибке

Workbooks.Open Filename:=pathtothefile
Workbooks(pathtothefile).Activate
With ThisWorkbook.Worksheets(«Лист1»)
‘——————————————————————
ПоследняяСтрокаБД = .Range(«a» & .Rows.Count).End(xlUp).Row ‘ вычисляем номер последней строки
Dim РезультатПоиска As Range, АдресПервойНайденнойЯчейки As String

Set РезультатПоиска = Cells.Find(ТекстДляПоиска, LookAt:=xlPart) ‘ начинаем поиск

If Not РезультатПоиска Is Nothing Then ‘ если нашли хоть одну подходящую ячейку
АдресПервойНайденнойЯчейки = РезультатПоиска.Address ‘ запоминаем Адрес Первой Найденной Ячейки
НомерСтроки = РезультатПоиска.Row ‘ получаем номер строки, в которой найдена подходящая ячейка
СписокНомеровНайденныхСтрок.Add НомерСтроки, CStr(НомерСтроки) ‘ записываем номер строки в список
Do
‘ ищем следующую ячейку
Set РезультатПоиска = Cells.FindNext(РезультатПоиска)

If Not РезультатПоиска Is Nothing Then ‘ если нашли очередную подходящую ячейку
НомерСтроки = РезультатПоиска.Row ‘ получаем номер строки, в которой найдена подходящая ячейка
СписокНомеровНайденныхСтрок.Add НомерСтроки, CStr(НомерСтроки) ‘ записываем номер строки в список
End If

‘ повторяем поиск до тех пор, пока не дойдм до Первой Найденной Ячейки
Loop While РезультатПоиска.Address <> АдресПервойНайденнойЯчейки
End If
‘——————————————————————
End With
ActiveWorkbook.Close False

On Error GoTo 0 ‘ отключение режима пропуска ошибок
‘——————————————————————
Range(«a» & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
Array(filenumber, Filename, pathtothefile, creationdate, filesize)

‘ если нужна гиперссылка на файл во втором столбце
ActiveSheet.Hyperlinks.Add Range(«b» & Rows.Count).End(xlUp), pathtothefile, «», _
«Открыть файл» & vbNewLine & Filename

On Error GoTo 0

Range(«a:e»).EntireColumn.AutoFit ‘ автоподбор ширины столбцов
End Sub

[/vba]

Заранее благодарен. Просьба не судить за русскоязычные переменные, знаю что это не правильно.
[moder]Оформите код тегами (кнопка #)[/moder]

К сообщению приложен файл:

6067555.xlsm
(31.5 Kb)

Сообщение отредактировал scofield — Понедельник, 28.09.2015, 11:34

Ответить

KSV

Дата: Понедельник, 28.09.2015, 11:58 |
Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 770

Репутация:
255
±

Замечаний:
0% ±

Excel 2013

Добрый день!
Открывайте так: [vba]

Код

Set WB = Workbooks.Open(Filename:=pathtothefile)

[/vba] а потом ищите так: [vba]

Код

Set РезультатПоиска = WB.ActiveSheet.Cells.Find(ТекстДляПоиска, LookAt:=xlPart)

[/vba]

К сообщению приложен файл:

8095689.xlsm
(29.6 Kb)

KSV.VBA@gmail.com
Яндекс.Деньги: 410011921213333

Ответить

scofield

Дата: Понедельник, 28.09.2015, 12:30 |
Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация:
0
±

Замечаний:
0% ±

Excel 2013

Спасибо, все заработало!)
Помогите, пожалуйста с выводом данных
[vba]

Код

СписокНомеровНайденныхСтрок.Add НомерСтроки, CStr(НомерСтроки)

[/vba]
Сюда записывается только Номер найденной строки, а если необхожимо что бы записывалось сама ячейка и ее адрес
И как потом вывод в цикле организовать
[vba]

Код

For j = 1 To СписокНомеровНайденныхСтрок.Count

НомерСтроки = СписокНомеровНайденныхСтрок.Item(j)

Range(«a» & Rows.Count).End(xlUp).Offset(1).Resize(, 6).Value = _
Array(filenumber, Filename, pathtothefile, creationdate, filesize, НомерСтроки)

            ‘ если нужна гиперссылка на файл во втором столбце
         ActiveSheet.Hyperlinks.Add Range(«b» & Rows.Count).End(xlUp), pathtothefile, «», _
                    «Открыть файл» & vbNewLine & Filename
         Next

[/vba]

Ответить

KSV

Дата: Понедельник, 28.09.2015, 13:11 |
Сообщение № 4

Группа: Друзья

Ранг: Ветеран

Сообщений: 770

Репутация:
255
±

Замечаний:
0% ±

Excel 2013

необхожимо что бы записывалось сама ячейка

не понял вопрос…
вам так надо? [vba]

Код

СписокАдресовНайденныхЯчеек.Add РезультатПоиска.Address(0, 0), РезультатПоиска.Address(0, 0) ‘ в формате A1
СписокАдресовНайденныхЯчеек.Add РезультатПоиска.Address(,,,1), РезультатПоиска.Address.Address(,,,1) ‘ в формате [имя файла книги]Лист1!$A$1

[/vba]

KSV.VBA@gmail.com
Яндекс.Деньги: 410011921213333

Ответить

scofield

Дата: Понедельник, 28.09.2015, 13:15 |
Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация:
0
±

Замечаний:
0% ±

Excel 2013

Ну надо, что бы в конце вывод выводилась информация о файле (filenumber, Filename, pathtothefile, creationdate, filesize)и тут же текст найденной ячейки и ее адрес (формат А1), наверно нужно доп массив заводить

Сообщение отредактировал scofield — Понедельник, 28.09.2015, 13:20

Ответить

KSV

Дата: Понедельник, 28.09.2015, 14:32 |
Сообщение № 6

Группа: Друзья

Ранг: Ветеран

Сообщений: 770

Репутация:
255
±

Замечаний:
0% ±

Excel 2013

текст найденной ячейки и ее адрес

можно так [vba]

Код

СписокАдресовНайденныхЯчеек.Add РезультатПоиска.Value, РезультатПоиска.Address(0, 0)

[/vba]

что бы в конце вывод выводилась информация о файле

можно объявить на уровне модуля [vba]

Код

Dim coll As New Collection

[/vba]
и в GetAllFileNamesUsingFSO сохранять инфу о файле [vba]

Код

    For Each fil In curfold.Files    ‘ перебираем все файлы в папке FolderPath
         coll.Add Array(fil.Name, fil.Path, fil.DateCreated, fil.Size)
     Next

[/vba]
а потом ее можно выводить так [vba]

Код

‘…

                   With Range(«a» & Rows.Count).End(xlUp).Offset(1)
             .Value = i                    ‘ номер файла
             .Offset(, 1).Resize(, 4).Value = coll(i)    ‘ инфа о файле
             With .Cells(, 2)
                 Filename = .Value
                 .Hyperlinks.Add .Cells(1), .Cells(, 2), , «Открыть файл» & vbNewLine & Filename, Filename
             End With
         End With
     Next

[/vba]

KSV.VBA@gmail.com
Яндекс.Деньги: 410011921213333

Ответить

KSV

Дата: Понедельник, 28.09.2015, 15:39 |
Сообщение № 7

Группа: Друзья

Ранг: Ветеран

Сообщений: 770

Репутация:
255
±

Замечаний:
0% ±

Excel 2013

и я бы написал так: [vba]

Код

Dim colFileInfo As New Collection

Sub GetFilesInfo(ByVal DirPath As String, Optional ByVal FileMask As String = «*», _
                     Optional ByVal SearchDeep As Long = 999)
      ‘ Получает в качестве параметра путь к папке DirPath,
      ‘ маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
      ‘ и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
      ‘ Возвращает коллекцию, содержащую полные пути найденных файлов
      ‘ (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
      Dim FSO As Object
      Set FSO = CreateObject(«Scripting.FileSystemObject»)                ‘ создаём экземпляр FileSystemObject
      GetFilesInfoUsingFSO FSO.GetFolder(DirPath), FileMask, SearchDeep   ‘ поиск
      Set FSO = Nothing: Application.StatusBar = False                    ‘ очистка строки состояния Excel
End Sub

      Private Function GetFilesInfoUsingFSO(objFolder As Object, ByVal FileMask As String, ByVal SearchDeep As Long)
      ‘ перебирает все файлы и подпапки, используя объект FSO
      ‘ перебор папок осуществляется в том случае, если SearchDeep > 1
      ‘ добавляет пути найденных файлов в коллекцию colFileInfo

              ‘ раскомментируйте эту строку для вывода пути к просматриваемой
      ‘ в текущий момент папке в строку состояния Excel
      ‘Application.StatusBar = «Поиск в папке: » & objFolder.Path

              Dim objFile As Object
      For Each objFile In objFolder.Files ‘ перебираем все файлы в папке
          With objFile
              If .Name Like FileMask Then colFileInfo.Add Array(.Name, .Path, .DateCreated, .Size)
          End With
      Next

              SearchDeep = SearchDeep — 1                     ‘ уменьшаем глубину поиска в подпапках
      If SearchDeep Then                    ‘ если надо искать глубже
          For Each objFolder In objFolder.SubFolders  ‘ перебираем все подпапки в папке
              GetFilesInfoUsingFSO objFolder, FileMask, SearchDeep
          Next
      End If
End Function

[/vba]
[p.s.]для заполнения коллекции colFileInfo нужно вызвать процедуру GetFilesInfo [vba]

Код

Sub test()
GetFilesInfo «C:UsersUserDownloadsDDE», «*.xls*» ‘ добавляем в коллекцию файлы *.xls, *.xlsb, *.xlsm, *.xlsx
End Sub

[/vba][/p.s.]

KSV.VBA@gmail.com
Яндекс.Деньги: 410011921213333

Сообщение отредактировал KSV — Понедельник, 28.09.2015, 15:41

Ответить

scofield

Дата: Понедельник, 28.09.2015, 16:04 |
Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация:
0
±

Замечаний:
0% ±

Excel 2013

Спасибо большое за помощь, все заработало как надо

Ответить

Источник

New

Пользователь

Сообщений: 4581
Регистрация: 06.01.2013

Может кому-нибудь будет нужен такой макрос.

В файле присутствует макрос «Поиск Во Всех Файлах И Папках»

Данный макрос:
1. запрашивает текст для поиска (число, слово, выражение);
2. запрашивает папку для поиска;
3. уточняет, искать ли данные во вложенных папках (Папка1Папка2Папка3 и т.д.);
4. осуществляет поиск текста во всех файлах Excel, на всех листах, во всех вложенных папках (если в пункте 3 ответили «Да»)
5. создаёт отдельную книгу с листом «Отчёт», куда копирует найденную информацию целыми строками, с указанием папки, названия книги и листа, где было найдено

Если кому-то не понравится вид, в котором макрос отображает результат поиска, то он всегда сам сможет подкорректировать макрос под свои нужды (код открыт).

Если кто найдёт ошибки в коде — пишите, постараюсь исправить

Dophin Пользователь Сообщений: 2684 Регистрация: 01.01.1970	он чем то лучше стандартного виндовского?

Serge Пользователь Сообщений: 11308 Регистрация: 01.01.1970	Супер! Спасибо Павел. ЗЫ В копилку.

	{quote}{login=Dophin}{date=07.04.2010 07:05}{thema=}{post}он чем то лучше стандартного виндовского?{/post}{/quote} см. п. 5. Z.

Serge Пользователь Сообщений: 11308 Регистрация: 01.01.1970	{quote}{login=Dophin}{date=07.04.2010 07:05}{thema=}{post}он чем то лучше стандартного виндовского?{/post}{/quote}Андрей, попробуй! И сравни скорость для начала…

Hugo Пользователь Сообщений: 23251 Регистрация: 22.12.2012	По-моему, лучше виндовского даже поиск в Тотале и AvSearch…

	Ааа, ругается на FD As FileDialog: ————————— Microsoft Visual Basic ————————— Compile error: User-defined type not defined ————————— что надо подключить? Офис 2000, ХР СП3.

Hugo Пользователь Сообщений: 23251 Регистрация: 22.12.2012	Я понял, msoFileDialogFolderPicker не идёт под 2000. Как и весь FileDialog… Нельзя сделать версию под 2000? А то я сам боюсь чего-нибудь поломаю….

Dophin Пользователь Сообщений: 2684 Регистрация: 01.01.1970	рассмотрел поближе) прикольно. Спасибо)

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013	Hugo, посмотрите этот файл. У меня, к сожалению, нет Excel 2000, поэтому я не могу проверить свой код. Отпишитесь, пожалуйста, сработает у вас этот макрос или нет. P.S. Данный файл только для людей с Excel 2000

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013	Небольшое дополнение к коду. Нужно добавить строку FoundAny = False в любое место в начале кода.

Hugo Пользователь Сообщений: 23251 Регистрация: 22.12.2012	Работает версия для 2000, и без FoundAny = False, и уже с. Только нестабильно, пару раз вылетал Эксель. Но только надо из кода FD As FileDialog убрать — забылось

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013	Странно, у меня в Excel 2003 ни разу не вылетало ) Немного доработал код, чтобы он определял версию Excel и показывал разное окно выбора папки (для Excel 2003 одно, для Excel 2000 — другое)

Hugo Пользователь Сообщений: 23251 Регистрация: 22.12.2012	Он, зараза, прежде чем условия проверять, объявления переменных проверяет… и естественно, опять Dim FD As FileDialog

Hugo Пользователь Сообщений: 23251 Регистрация: 22.12.2012	а затем уже и picker… В общем, я эту парочку заглушил — работает!

Haken

Пользователь

Сообщений: 495
Регистрация: 09.01.2013

а в обработку версий можно еще добавить, что если 2007, то он бы искал
If LCase(Right(iFile, 4)) = «xlsx» Then…
?
Павел, Вы как не зайдете, так у Вас такие глобальные проекты, в которые каждый хочет свои хотелки включить (это я про калькулятор вспомнил :))

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013	{quote}{login=Hugo}{date=07.04.2010 10:59}{thema=}{post}а затем уже и picker… В общем, я эту парочку заглушил — работает!{/post}{/quote} Ну, и отлично) просто мне без установленного Excel 2000 трудно предлагать варианты решения )

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013	Haken )) Сергей, а это идея про Excel 2007 )) надо подумать) P.S. ой, про калькулятор и не вспоминайте )) а то мне плохо становится ))

Haken

Пользователь

Сообщений: 495
Регистрация: 09.01.2013

всё-таки, я бы по умолчанию убрал «текст для поиска». а то вдруг кто-нибудь захочет именно «текст для поиска» найти, а он ошибку выдаст…

К 2007 продолжение идеи: там же куча расширений появляется… xlsm, xlsb…
наверно при 2003 и ниже надо смотреть файлы *xls (как сейчас), а при 2007 — и эти, и *xls? — т.е. без последнего знака.

на всякий случай (а то мало ли нет под рукой 2007 ;)))
Application.Version = 12.0

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013	Вот доработал для Excel 2007. Потестируйте ) P.S. В Excel 2000 — не работает )

Микки

Пользователь

Сообщений: 3280
Регистрация: 24.12.2012

{quote}{login=Pavel55}{date=08.04.2010 12:27}{thema=}{post}Вот доработал для Excel 2007. Потестируйте )

P.S. В Excel 2000 — не работает ){/post}{/quote}
Протестируйте- заметьте не я это предложил. Историю с калькулятором помню.. сочуствую.
А можно сделать так чтобы найденный адрес слова фразы был гиперссылкой на найденое место?

New Пользователь Сообщений: 4581 Регистрация: 06.01.2013

Микки

Пользователь

Сообщений: 3280
Регистрация: 24.12.2012

{quote}{login=Pavel55}{date=08.04.2010 02:45}{thema=}{post}Микки, так подойдёт? ){/post}{/quote} <BR>Выкладываю результат .. как гиперссылка на указанную папку книгу и лист не работает (а хотелось именно так).. и книга не может быть у меня названа Лист4 <BR><STRONG>Файл удален</STRONG> — велик размер. [Модераторы]

Микки, вы выложили большой файл и модераторы его удалили. Сожмите ваш файл WinRar’ом.

P.S. Люди, а кто знает, как сделать гиперссылку на определённый файл с определённым листом и определённой ячейкой?

У меня получается лишь на книгу сделать
Papka = «C:Temp»
iTempWB.Name = «Книга1.xls»
ActiveSheet.Hyperlinks.Add Anchor:=Cells(1, 1), Address:=Papka & iTempWB.Name

А нужно что-то типа: ='»C:Temp[Книга1.xls]Лист3′!$B$45″

Юрий М Модератор Сообщений: 60575 Регистрация: 14.09.2012 Контакты см. в профиле	А вот так разве не пойдёт?

Юрий М Модератор Сообщений: 60575 Регистрация: 14.09.2012 Контакты см. в профиле	Дим, у меня открывает именно указанную книгу, на нужном листе и активирует указанную ячейку. Может в 2007-ом не так?

Юрий М Модератор Сообщений: 60575 Регистрация: 14.09.2012 Контакты см. в профиле	Проверили на одном экземпляре 2007-го — гиперссылка не активирует нужную ячейку на нужном листе в нужной книге. Это у всех так? У меня (2003) работает корректно.

New

Пользователь

Сообщений: 4581
Регистрация: 06.01.2013

Я пробовал вчера, когда корректировал макрос для Гиперссылки. У меня не вышло. Гиперссылка открывает лишь ту книгу с тем активным листом, с которым книга была сохранена. Т.е. если код нашёл совпадения на Лист5, а книга была сохранена с активным Лист1, то гиперссылка отрывает файл с Лист1.

Микки, как видишь не получается так, как ты хочешь.

P.S. Немного обновил файл.

P.P.S. Проверял макрос на нескольких компах, с поискам по многим файлам (более 100), он где-то выдаёт ошибку 13 (Type Mismatch), заметил, что в тех файлах присутствовали листы с Диаграммами. Т.к. макрос проходит по всем листам и видно случается ошибка на листе с Диаграммой, т.к там нем Cells.

Сейчас заменил строку

For Each iSht In iTempWB.Sheets

на

For Each iSht In iTempWB.Worksheets

надеюсь такой ошибку больше не будет.

szt72 Пользователь Сообщений: 15 Регистрация: 01.01.1970

Микки Пользователь Сообщений: 3280 Регистрация: 24.12.2012	#30 12.04.2010 10:06:21 Не судьба у меня кстати тоже ошибка выскакивала, очень хорошо что исправили. За то что сделали огромное спасибо.

Источник

Остап Бонд, Если можно и сразу так перебрать то хорошо. Только знать бы как это реализовать..

Добавлено через 3 минуты
Остап Бонд,

Option Explicit

Dim FSO As Object, iFolder As Object, iFile As Object, FD As FileDialog, ExtArray() As Variant
Dim iPath As String, firstAddress As String, iPathName As String, Recursion As Boolean
Dim iSht As Worksheet, iReportSht As Worksheet, iTempWB As Workbook, ExcelVersion As Byte
Dim TextToFind As Variant, iFoundRng As Range, iLastRow As Long, FoundAny As Boolean, iTotalFiles As Long

Sub ÏîèñêÂîÂñåõÔàéëàõÈÏàïêàõ()
‘Ïîèñê òåêñòà âî âñåõ Excel ôàéëàõ íà âñåõ ëèñòàõ â óêàçàííîé ïàïêå
’10/10/2008; 07/04/2010

Recursion = False: iPathName = «»: FoundAny = False
TextToFind = Trim(Worksheets(«Ëèñò1»).Range(«C2»).Value)
If TextToFind = «» Or TextToFind = False Then Exit Sub
TextToFind = Trim(TextToFind)

Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.AllowMultiSelect = False
.Title = «Óêàæèòå íóæíóþ äèðåêòîðèþ»
.ButtonName = «Âûáðàòü ïàïêó»
If .Show = False Then Exit Sub Else iPath = .SelectedItems(1) & Application.PathSeparator
End With
Set FD = Nothing

If MsgBox(«Ïðîñìàòðèâàòü âëîæåííûå ïàïêè?», vbQuestion + vbYesNo, «Ðåêóðñèÿ») = vbYes Then Recursion = True

Set iReportSht = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
With iReportSht
.Name = «Îò÷¸ò»
With .Cells(1, 1)
.Value = «Ïîèñê òåêñòà: » & «»»» & TextToFind & «»»»
.Font.Bold = True
End With
End With

With Application
.ScreenUpdating = False
.Calculation = xlManual
.EnableEvents = False
.ShowWindowsInTaskbar = False

On Error GoTo ErrHandler:
ExcelVersion = Val(Application.Version)
ExtArray = Array(«xls», «xlsx», «xlsm», «xlsb», «csv») ‘çäåñü ìîæíî óêàçàòü, êàêèå ðàñøèðåíèÿ áóäåì îáðàáàòûâàòü
Set FSO = CreateObject(«Scripting.FileSystemObject»)
ChooseFoldersSubfoldersFSO (iPath)
Set iFolder = Nothing
Set FSO = Nothing
iReportSht.Cells(2, 1).Select

.StatusBar = False
.ShowWindowsInTaskbar = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

If FoundAny = False Then
MsgBox «Òåêñò ‘» & TextToFind & «‘ íè â îäíîì èç ôàéëîâ â ïàïêå:» & Chr(10) & «‘» & iPath & «‘» & » íå áûë íàéäåí!» _
& Chr(10) & «Âñåãî áûëî îáðàáîòàíî: » & iTotalFiles & » ôàéëîâ», 48, «Îò÷¸ò»
iReportSht.Parent.Close SaveChanges:=False
Exit Sub
End If
MsgBox «Ïîèñê çàâåðø¸í!» & Chr(10) & «Âñåãî îáðàáîòàíî: » & iTotalFiles & » ôàéëîâ», 64, «Ïîèñê»
Exit Sub

ErrHandler:
If Err <> 0 Then MsgBox «Ïðîèçîøëà íåïðåäâèäåííàÿ îøèáêà: » & Err.Number & Chr(10) & Err.Description, 48, «Îøèáêà»
With Application
.StatusBar = False
.ShowWindowsInTaskbar = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Function ChooseFoldersSubfoldersFSO(ByVal Papka As String)

Set iFolder = FSO.GetFolder(Papka)
For Each iFile In iFolder.Files
If Not IsError(Application.Match(FSO.GetExtensionName(iFi le), ExtArray(), 0)) Then
If CanOpenFile = True Then
If iFile.Name <> ThisWorkbook.Name Then
Set iTempWB = Workbooks.Open(Filename:=Papka & iFile.Name, UpdateLinks:=False, ReadOnly:=True)
iTotalFiles = iTotalFiles + 1
Application.StatusBar = «Ïîèñê â: » & iTempWB.FullName
For Each iSht In iTempWB.Worksheets
If iSht.FilterMode = True Then iSht.ShowAllData
Set iFoundRng = iSht.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
If Not iFoundRng Is Nothing Then
FoundAny = True
firstAddress = iFoundRng.Address
Do
With iReportSht
iLastRow = .UsedRange.Rows.Count + .UsedRange.Row
If iPathName <> Papka Then ‘åñëè íîâûé ôàéë
iPathName = Papka
With .Cells(iLastRow + 2, 1)
.Value = «Äèðåêòîðèÿ: » & Papka
.Font.Bold = True
End With
.Hyperlinks.Add Anchor:=.Cells(iLastRow + 3, 1), Address:=Papka & iTempWB.Name, ScreenTip:=»Êíèãà: » & iTempWB.Name & «, Ëèñò: » & iSht.Name, TextToDisplay:=»Êíèãà: » & iTempWB.Name & «, Ëèñò: » & iSht.Name
With .Cells(iLastRow + 3, 1)
End With
Else
.Hyperlinks.Add Anchor:=.Cells(iLastRow + 1, 1), Address:=Papka & iTempWB.Name, ScreenTip:=»Êíèãà: » & iTempWB.Name & «, Ëèñò: » & iSht.Name, TextToDisplay:=»Êíèãà: » & iTempWB.Name & «, Ëèñò: » & iSht.Name
With .Cells(iLastRow + 1, 1)
End With
End If
iFoundRng.EntireRow.Copy ‘êîïèðóåì âñþ ñòðîêó
.Cells(.UsedRange.Rows.Count + .UsedRange.Row, «A»).PasteSpecial xlPasteValues ‘âñòàâëÿåì òîëüêî çíà÷åíèÿ
End With
Set iFoundRng = iSht.Cells.FindNext(iFoundRng)
Loop While iFoundRng.Address <> firstAddress
End If
Next
Application.CutCopyMode = False
iTempWB.Close SaveChanges:=False
End If
End If
End If
Next

If Recursion Then ‘ðåêóðñèÿ
For Each iFolder In iFolder.SubFolders
ChooseFoldersSubfoldersFSO iFolder.Path & Application.PathSeparator
Next
End If
End Function

Function CanOpenFile() As Boolean
‘ïðîâåðÿåì, ìîæåì ëè ìû îòêðûòü äàííîå ðàñøèðåíèå ôàéëà â òåêóùåé âåðñèè Excel
‘åñëè Excel âåðñè 2007 è âûøå
If ExcelVersion >= 12 Then CanOpenFile = True: Exit Function
‘åñëè Excel âåðñè 2003 è íèæå
If ExcelVersion < 12 And FSO.GetExtensionName(iFile) = «xls» Then CanOpenFile = True
End Function

Источник

Получение списка файлов в указанной папке с помощью кода VBA Excel. Коллекция Files объекта Folder, возвращенного методом FileSystemObject.GetFolder.

Коллекция Files объекта Folder

Для получения списка файлов в указанной папке используется свойство Files объекта Folder. Объект Folder в VBA Excel возвращается методом GetFolder объекта FileSystemObject по полному имени папки в качестве аргумента.

Если в указанной папке нет файлов, применение свойства Folder.Files приведет к возникновению ошибки. Для корректного завершения программы используйте обработчик ошибок или условие, проверяющее наличие файлов в папке.

Получение списка файлов в папке

Пример 1

Код VBA Excel для получения списка файлов в указанной папке и записи полных имен файлов в массив (с поздней привязкой объектов к переменным):

Sub Primer1()

Dim fso, myPath, myFolder, myFile, myFiles(), i

‘Записываем в переменную myPath полное имя папки

myPath = «C:DATAТекущая папка»

‘Создаем новый экземпляр FileSystemObject

Set fso = CreateObject(«Scripting.FileSystemObject»)

‘Присваиваем переменной myFolder ссылку на объект Folder

Set myFolder = fso.GetFolder(myPath)

‘Проверяем, есть ли файлы в папке myFolder

If myFolder.Files.Count = 0 Then

MsgBox «В папке «» & myPath & «» файлов нет»

Exit Sub

End If

‘Задаем массиву размерность

ReDim myFiles(1 To myFolder.Files.Count)

‘Загружаем в массив полные имена файлов

For Each myFile In myFolder.Files

i = i + 1

myFiles(i) = myFile.Path

‘Просматриваем первый элемент массива

MsgBox myFiles(1)

End Sub

Используемые переменные:

fso – ссылка на экземпляр объекта FileSystemObject;
myPath – полное имя папки;
myFolder – ссылка на объект Folder (папка);
myFile – ссылка на один объект File из коллекции myFolder.Files;
myFiles() – массив для записи имен файлов;
i – счетчик элементов массива.

Пример 2

Получение списка файлов в указанной папке и запись имен файлов в ячейки первого столбца рабочего листа Excel (с ранней привязкой объектов к переменным):

Sub Primer2()

Dim myPath, myFolder As Folder, myFile As File, i

‘Записываем в переменную myPath полное имя папки

myPath = «C:DATAТекущая папка»

‘Создаем новый экземпляр FileSystemObject

Dim fso As New FileSystemObject

‘Присваиваем переменной myFolder ссылку на объект Folder

Set myFolder = fso.GetFolder(myPath)

‘Проверяем, есть ли файлы в папке myFolder

If myFolder.Files.Count = 0 Then

MsgBox «В папке «» & myPath & «» файлов нет»

Exit Sub

End If

‘Записываем имена файлов в первый столбец активного листа

For Each myFile In myFolder.Files

i = i + 1

Cells(i, 1) = myFile.Name

End Sub

Ранняя привязка позволяет использовать подсказки свойств и методов объектов при написании кода VBA Excel.

Как получить список папок до 3 уровней вложенности, смотрите в статье VBA Excel. Список папок.

Фразы для контекстного поиска: обход файлов.

Источник