Поиск файла макросом excel

 

lenok

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

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

Помогите, пожалуйста.
Как в определенной папке с помощью макроса найти и открыть фаил с названием из ячейки???
Заранее, спасибо большое

 

Johny

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

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

А файл какой? Excel?

There is no knowledge that is not power

 

lenok

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

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

да. в 2003 экселе пытаюсь написать

 

Johny

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

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

#4

23.05.2013 11:40:58

Код
Sub f()

    Dim f As String, folder As String, file_name As String

    'Папка для поиска
    folder = "C:Temp"
    
    'Ячейка с именем файла
    file_name = Range("A1")
    
    f = Dir(folder)
    While Not Len(f) = 0
        If f = file_name Then
            Workbooks.Open folder & f
        End If
        f = Dir()
    Wend

End Sub

There is no knowledge that is not power

 

lenok

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

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

 

lenok

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

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

а как сделать, чтобы выбор варианта ответа при появлении диалогового окна был автоматический, или чтобы оно вообще не вылазило???

 

Johny

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

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

#7

24.05.2013 14:28:11

Код
Application.DisplayAlerts = False
.....
.....
.....
Application.DisplayAlerts = True

Изменено: Johny24.05.2013 14:28:36

There is no knowledge that is not power

 

lenok

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

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

а можно ли сделать, чтобы он искал документ в поддиректориях??? :oops:

 

Johny

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

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

#9

31.05.2013 17:18:58

Ставим галку: Tools -> References -> Microsoft Scripting Runtime

Код
Private file_name As String
Private f As File, fld As folder

Sub SearchAndOpen()

    Dim source_folder As String
    Dim fso As New FileSystemObject

    'Папка для поиска
    source_folder = "C:TempDir"
    
    'Ячейка с именем файла
    file_name = Range("A1")
    
    Call EnumerateFiles(fso.GetFolder(source_folder))

End Sub

Private Sub EnumerateFiles(root_folder As folder)

    For Each f In root_folder.Files
        If f.Name = file_name Then
            Workbooks.Open f.Path
        End If
    Next
    
    For Each fld In root_folder.SubFolders
        Call EnumerateFiles(fld)
    Next
    
End Sub

Изменено: Johny31.05.2013 17:19:49

There is no knowledge that is not power

 

Hugo

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

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

#10

31.05.2013 17:29:09

Я чего-то не понимаю?
Если есть имя файла — то зачем искать? Взяли и открыли. Если ошибка — обработали.
А искать может быть долго — если например файлов тысячи. Да и код с таким поиском больно длинный  — хватает ведь 3-х строк:

Код
Sub f()
    On Error GoTo err_: Workbooks.Open "C:Temp" & Range("A1"): Exit Sub
err_:     MsgBox "Нет такого файла!"
End Sub
 

Юрий М

Модератор

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

Контакты см. в профиле

Я тоже не понимаю смысла в поиске…

 

KuklP

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

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

E-mail и реквизиты в профиле.

Я сам — дурнее всякого примера! …

 

lenok

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

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

Просто документов очень много. и постоянно открывать файлы под определенными названиями….. смысл тогда составления макроса… Пишу для автоматизации процессов обработки информации, и остановилась на этом моменте.

:oops:

 

Hugo

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

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

Если например ситуации такие:
— есть точный список названий файлов
— в определённом месте (папки/подпапки) регулярно генерятся файлы (известна часть имени, или даже не известна)
— нужно открыть все файлы определённой папки/подпапки
— есть какая-то другая система в этих файлах
и открывать такие файлы предстоит регулярно — то есть смысл один раз и надолго облегчить себе работу макросом.
Если же никакой системы нет — то и макросом открывать файлы нет смысла.
Другое дело, что если обработка этих открываемых файлов предстоит макросом — то можно в этот же макрос вписать диалог выбора этих файлов. Т.е. запустили макрос, в диалоге указали сразу все нужные файлы, получили готовый результат.

 

lenok

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

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

Есть огромный отчет. после обработки макросом, надо, чтобы он брал имя файла из определенной ячейки и открывал фаил с таким именем. информации много, и такой отчет обрабатывается каждый месяц. примерное кол-во файлов на один отчет больше 1000, поэтому, сами понимаете, что открывать каждый, это рутина. таких отчетов за один месяц 30 штук. соответственно, около 30000 существующих файлов…вот как-то так все глобально……

просто открыть, с этим мы разобрались….. но некоторые файлы находятся в поддиректориях, и постоянно происходят какие-то перемещения в этой директории…

 

Hugo

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

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

#16

03.06.2013 11:32:43

В теме

http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=25457

есть файл

http://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=40202&action=download

Там есть такой код:

Код
    For Each aFolder In fso.GetFolder(ThisWorkbook.Path).Files
    
        For Each aFile In aFolder.Files
        
            If fso.GetExtensionName(aFile.Name) Like "xls*" Then
            
                Set wkb = Workbooks.Open(aFile.Path)
                Set wks = wkb.Worksheets(1)
                With wks

и т.д.
Думаю, можно использовать.

 

lenok

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

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

что-то я не могу разобраться совсем :cry:

 

anvg

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

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

Excel 2016, 365

Пробуйте, первый запуск будет долгим. Далее быстрее. Если есть подозрение, что файлы в папке и подпапках изменили положение или имя, то нажать «Обновить». Путь к начальной папке задаётся константой baseFolder в методе InitializeFindю
Успехов.

 

lenok

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

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

#19

04.06.2013 07:29:04

Код
    Const baseFolder = "d:project"

я так понимаю, здесь надо прописать адрес самой папки, это понятно…
а имя файла он где будет брать???

 

anvg

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

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

Excel 2016, 365

#20

04.06.2013 07:50:49

Цитата
а имя файла он где будет брать???

Из активной ячейки (в ней только имя, без расширения)

Изменено: anvg04.06.2013 07:52:42

 

lenok

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

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

#21

04.06.2013 08:07:46

все, поняла….. все работает…спасибо большое….   :D  и еще один вопрос, если можно….:
как это все сделать так, чтобы он был без этих кнопочек, а в таком виде, чтобы автоматически включался???

до этого было прописано так, но он только с одной папки так открывает….
Заранее огромное спасибо вам!!!!!!!!   :oops:  

Код
Sub ARM()
    Dim f As String, folder As String, file_name As String
    'Папка для поиска
    folder = "C:Documents and SettingsmaksРабочий столДокументы"
    'Ячейка с именем файла
    file_name = LCase(Range("D1")) & ".xls"
    f = Dir(folder)
    While Not Len(f) = 0
        If LCase(f) = file_name Then

            Workbooks.Open folder & f
           
 Application.Run "ARM.XLS!ARM6"
            Exit Sub
        End If
        f = Dir()
    Wend

    Application.Run "ARM.XLS!ARM4"
End Sub

Изменено: lenok04.06.2013 23:58:03

 

KuklP

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

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

E-mail и реквизиты в профиле.

#22

04.06.2013 08:24:36

А на кой тут цикл? Если имя файла известно, зачем перебирать все файлы?

Код
Sub ARM()
    Dim folder As String, file_name As String
    'Папка для поиска
    folder = "C:Documents and SettingsmaksРабочий столДокументы"
    'Ячейка с именем файла
    file_name = LCase(Range("D1")) & ".xls"
    If Len(Dir(folder & file_name)) Then
        Workbooks.Open folder & file_name
        Application.Run "ARM.XLS!ARM6"
        Exit Sub
    End If
    Application.Run "ARM.XLS!ARM4"
End Sub

Я сам — дурнее всякого примера! …

 

lenok

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

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

он не открывает тогда файл в поддиректории :(

 

KuklP

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

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

E-mail и реквизиты в профиле.

Ага. А с циклом, следовательно, открывает?

Я сам — дурнее всякого примера! …

 

lenok

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

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

неа…  тоже не открывает….   :| а надо, чтобы открывал… там мне уже без разницы, есть цикл или нет… надо, чтобы он поддиректории просматривал :?:

 

anvg

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

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

Excel 2016, 365

#26

04.06.2013 09:43:56

:?:

Скрытый текст

 

lenok

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

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

 

Sandero

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

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

#28

18.06.2019 13:20:28

Цитата
Hugo написал:
Я чего-то не понимаю?Если есть имя файла — то зачем искать? Взяли и открыли. Если ошибка — обработали.А искать может быть долго — если например файлов тысячи. Да и код с таким поиском больно длинный  — хватает ведь 3-х строк

Добрый день!
Попробовал ваш вариант, работает. Я правда добавил ещё запуск другого макроса по созданию файла с этим именем если его нет (т.е. если не выполнено первое условие)
Эксель при отсутствии файла выдаёт своё собственное сообщение
По нажатии «оК» появляется уже месседж из макроса.
М.б. это связано с версией экселя, у меня 2016, а тут код вроде для 2003 изначально, или это не имеет значения.
Можно ли убрать сообщение самого экселя?
Заранее благодарен!!

Код
Sub SearhFiles() 'Макрос поиска файла с именем и автоматическое его открытие при наличии
On Error GoTo err_: Workbooks.Open "\Server777S" & Range("F2") & ".xls": Exit Sub
err_:     MsgBox "Нет такого файла!"
Application.Run "DOC.xlsm!Upload" 'Запуск макроса по созданию файла с именем
End Sub

Макрос VBA загрузки списка файлов из папки

Функция 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
  • 301904 просмотра

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

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

0 / 0 / 0

Регистрация: 05.05.2013

Сообщений: 57

1

Поиск файла в папке по тексту из ячейки книги

05.05.2013, 16:53. Показов 17658. Ответов 5


Студворк — интернет-сервис помощи студентам

Добрый день форумчане. Прошу помощи у Вас.
Задача следующая:
Есть папка на диске С, в ней файлы xls. В ячейке L1 рабочей книги находится текст который является частью названия файлов в папке на диске С (например «сводка» или «Отчет»). Нужен код vba который смог бы пересмотреть эти файлы в папке, отобрать те в названии которых присутсвует текст из ячейки L1, полные названия вписать в строки в рабочей книги, и из этого списка выбрать файл с последней датой создания.
Жду Ваших ответов.



0



Alex77755

11482 / 3773 / 677

Регистрация: 13.02.2009

Сообщений: 11,147

05.05.2013, 20:24

2

Для начала:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
  'Показываем диалог выбора папки 
  With Application.FileDialog(msoFileDialogFolderPicker) 
    .Title = "Выберите папку, файлы в которой нужно обработать" 
    .ButtonName = "Выбрать" 
    .AllowMultiSelect = False 
    If .Show Then Folder = .SelectedItems(1) Else Exit Sub 
  End With 
  'Начинаем читать файлы из папки 
  wb = Dir(Folder & Application.PathSeparator & "*.xls") ' здесь выбираются екселовские файлы
' модифицируйте под свои условия
  While Len(wb) > 0 ' если такой файл есть
'здесь добавить код проверки даты создания
 
    wb = Dir 'читаем следующий файл 
  Wend



1



Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

06.05.2013, 00:38

3

Цитата
Сообщение от stogs
Посмотреть сообщение

Нужен код vba который смог бы пересмотреть эти файлы в папке

Включая подпапки или нет?

Добавлено через 3 часа 28 минут
Так можно получить список файлов в указанной папке без подпапок, отсортированный по возрастанию даты, т.е. последний — самый свежий. Если желаете в обратном порядке — измените /o:d на /o:-d в параметрах dir.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub bb()
Dim fldr$, v
fldr = "C:Temp" 'папка, в которой искать файлы
With CreateObject("ADODB.Stream")
    .Type = 2 'adTypeText
    .Open
    .Charset = "Windows-1251"
'При передаче текстовых данных в VBA из не-Unicode источников в русском Windows
'используется эта кодировка (что в данном случае неправильно).
'Если назначить объекту ADODB.Stream эту кодировку, текст в нем будет перекодирован обратно.
    .WriteText CreateObject("wscript.shell").Exec("cmd /c dir /b/o:d """ & fldr & "*" & [L1] & "*.xls*""").StdOut.ReadAll
    .Position = 0
    .Charset = "cp866"
'А теперь назначили объекту ADODB.Stream правильную кодировку, которая будет использована
'в методе .ReadText для перекодирования в Unicode.
    v = Application.Transpose(Split(.ReadText, vbCrLf))
End With
[a1].Resize(UBound(v)).Value = v 'выгрузка списка файлов начиная с яч. А1
End Sub



2



0 / 0 / 0

Регистрация: 05.05.2013

Сообщений: 57

06.05.2013, 15:52

 [ТС]

4

Спасибо огромное, это именно то что мне нужно.



0



0 / 0 / 0

Регистрация: 05.05.2013

Сообщений: 57

14.05.2013, 14:32

 [ТС]

5

Доброго времени суток. Как то я сразу не подумал, и вот возникла в данном случае очередная проблема. Связана она с тем, что если вдруг в папке ктонибудь открывает старый файл и закрывает его потом с сохранением изменений, макросом потом этот файл воспринимается как самый свежий. Это не допустимо. Есть возможность сохранять файлы с датой, напимер «счет 12.05.2013». в таком случае необходима сортитовка по дате в названии файла. Как это сделать?
Жду Ваших ответов.



0



undefined7

259 / 7 / 1

Регистрация: 22.01.2013

Сообщений: 47

14.05.2013, 14:58

6

Цитата
Сообщение от stogs
Посмотреть сообщение

Доброго времени суток. Как то я сразу не подумал, и вот возникла в данном случае очередная проблема. Связана она с тем, что если вдруг в папке ктонибудь открывает старый файл и закрывает его потом с сохранением изменений, макросом потом этот файл воспринимается как самый свежий. Это не допустимо. Есть возможность сохранять файлы с датой, напимер «счет 12.05.2013». в таком случае необходима сортитовка по дате в названии файла. Как это сделать?
Жду Ваших ответов.

Вот 2 макроса, первый — создаёт лист и в нём записывает все файлы которые есть в текущей книги, можно соаздавать такой лист, а потом оттуда отсортировать и открыть нужный

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
    
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
    
    'добавляем лист и выводим на него шапку таблицы
'    ActiveWorkbook.Sheets.Add
    Sheets("FileList").Select
    Worksheets("FileList").Range("A1:E" & Range("A65536").End(xlUp).Row).ClearContents
    With Range("A1:E1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "Имя файла"
    Range("B1").Value = "Путь"
    Range("C1").Value = "Размер"
    Range("D1").Value = "Дата создания"
    Range("E1").Value = "Дата изменения"
    
    'вызываем процедуру вывода списка файлов
    'измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
 
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
    Dim X As Variant
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)
 
    r = Range("A65536").End(xlUp).Row + 1   'находим первую пустую строку
    'выводим данные по файлу
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = FileItem.Path
        Cells(r, 3).Formula = FileItem.Size
        Cells(r, 4).Formula = FileItem.DateCreated
        Cells(r, 5).Formula = FileItem.DateLastModified
        r = r + 1
        X = SourceFolder.Path
'        On Error Resume Next
    Next FileItem
    
    'вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Columns("A:E").AutoFit
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
 
End Sub



0



Skip to content

Как определить существует ли книга в папке

На чтение 2 мин. Просмотров 1.4k.

Что делает макрос: Данный макрос позволяет найти путь к определенному файлу, и проверить, существует ли книга в папке на компьютере.

Содержание

  1. Как макрос работает
  2. Код макроса
  3. Как работает этот код
  4. Как использовать

Как макрос работает

Данное действие называется функцией, а не процедурой sub. Данный макрос позволяет найти путь к любому файлу. В макросе, мы используем функцию Dir. Данная функция задает строку, представляющую собой имя файла, которого мы ищем. Эта функция может быть использована во многих отношениях, но в данный момент, мы используем его, чтобы найти путь к нужному нам файлу.

Код макроса

Function FileExists(FPath As String) As Boolean
'Шаг 1: Определить переменные.
Dim FName As String
'Шаг 2: Использовать функцию Dir, чтобы получить Имя файла
FName = Dir(FPath)
'Шаг 3: Если файл существует, возвращаем ИСТИНА, иначе ЛОЖЬ
If FName <> "" Then FileExists = True _
Else: FileExists = False
End Function

Как работает этот код

  1. Определяем переменную строку, содержащую имя файла, определённого из функции Dir. FName – это имя переменной строки.
  2. На шаге 2 устанавливаем переменную FName. Это выполняется посредством передачи переменной FPath к функции Dir. Переменная FPath проходит через выявленные функции (см. первую строку кода). Такой поиск позволяет четко прописать путь к файлу, ища его в качестве переменной.
  3. Если переменная FName не может быть выявлена, то это означает, что файла нет. Шаг 3 показывает либо ложный, либо истинный результат.

Как использовать

Для реализации этого макроса, вы можете скопировать и вставить его в стандартный модуль:

  1. Активируйте редактор Visual Basic, нажав ALT + F11.
  2. Щелкните правой кнопкой мыши имя проекта / рабочей книги в окне проекта.
  3. Выберите Insert➜Module.
  4. Введите или вставьте код во вновь созданном модуле.

Поиск файлов в каталоге по части имени из столбца таблицы

Данилкин

Дата: Вторник, 15.12.2015, 08:50 |
Сообщение № 1

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

Доброго дня. Подскажите как правильно решить задачу. Существует таблица описывающая объекты, каждый объект идентифицируется уникальным номером, для каждого объекта имеется фотография, частью имени которой является этот номер, требуется по произвольной выборке уникальных номеров, заданных таблицей excel, найти все файлы в заданном каталоге и его подкаталогах, содержащие в имени этот номер и скопировать их в произвольный каталог.

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

Poisk.xlsx
(12.0 Kb)

 

Ответить

SLAVICK

Дата: Вторник, 15.12.2015, 11:11 |
Сообщение № 2

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290


Репутация:

766

±

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


2019

Так? :
[vba]

Код

Sub d()
Dim f, i&, ii&, ar(), fol$, NewFol$
ar = [a2:a290].Value ‘Selection.Value
fol = [c2]
NewFol = [d2]
f = Enlist_Directories(fol)
For i = 1 To UBound(ar)
    For ii = 0 To UBound(f)
       If f(ii) Like «*» & ar(i, 1) & «*» Then Copy_File f(ii), NewFol & Dir(f(ii))
Next ii, i
End Sub
Private Function Copy_File(ByVal sFileName As String, ByVal sNewFileName As String) As Boolean
Dim objFSO As Object
    If sFileName = sNewFileName Then Exit Function
    If Dir(sFileName, 16) = «» Then: Exit Function
    If Not Dir(sNewFileName, 16) = «» Then Kill sNewFileName
Set objFSO = CreateObject(«Scripting.FileSystemObject»)
Call objFSO.CopyFile(sFileName, sNewFileName)
Copy_File = True
End Function
Function Enlist_Directories(strPath As String)
Dim strFldrList() As String
Dim lngArrayMax, x As Long, lngSheet&
lngSheet = 100 ‘As Long
lngArrayMax = 0
strFn = Dir(strPath & «*.*», 23)
While strFn <> «»

    If Not (GetAttr(strPath & strFn) And vbDirectory) = vbDirectory Then
      lngArrayMax = lngArrayMax + 1
      ReDim Preserve strFldrList(lngArrayMax)
      strFldrList(lngArrayMax) = strPath & strFn
    End If

  strFn = Dir()
Wend
Enlist_Directories = strFldrList
End Function

[/vba]

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

Poisk.xlsm
(23.9 Kb)


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICKВторник, 15.12.2015, 11:13

 

Ответить

Данилкин

Дата: Вторник, 15.12.2015, 11:39 |
Сообщение № 3

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, огромное спасибо! Сейчас буду разбираться. SLAVICK

 

Ответить

Данилкин

Дата: Вторник, 15.12.2015, 11:56 |
Сообщение № 4

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, не понял, зачем в первой колонке имена файлов, это осталось от проверки?

 

Ответить

Данилкин

Дата: Вторник, 15.12.2015, 12:04 |
Сообщение № 5

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, программа завершает работу ошибкой на первом цикле «For ii = 0 To UBound(f)», взглянете, я не вполне понимаю почему, пути на реальные заменил, файл прилагаю.

 

Ответить

Данилкин

Дата: Вторник, 15.12.2015, 12:04 |
Сообщение № 6

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, файл все-же прилагаю).

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

0177598.xlsm
(22.5 Kb)

 

Ответить

SLAVICK

Дата: Вторник, 15.12.2015, 12:19 |
Сообщение № 7

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290


Репутация:

766

±

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


2019

зачем в первой колонке имена файлов, это осталось от проверки?

Макрос ищет в папке поиска файлы, имена которых содержат данные из 1-й колонки. Я вставил несколько своих реальных имен для проверки.

цикле «For ii = 0 To UBound(f)»

У Вас в папке «F:TempDataBase» есть файлы?


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICKВторник, 15.12.2015, 12:20

 

Ответить

Данилкин

Дата: Вторник, 15.12.2015, 13:54 |
Сообщение № 8

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, по поводу первого столбца я так и понял, в папку DataBase я, на момент проверки работоспособности, запустил копирование файлов ~200GB и там что-то уже было, не факт, что с указанными в таблице уникальными номерами.

 

Ответить

SLAVICK

Дата: Вторник, 15.12.2015, 14:39 |
Сообщение № 9

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290


Репутация:

766

±

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


2019

Переделал немного.
Прошлый пример смотрел только в строго указанную папку.
Сейчас во всех вложенных подпапках тоже.
Использовал часть кода отсюда


Иногда все проще чем кажется с первого взгляда.

 

Ответить

Данилкин

Дата: Вторник, 15.12.2015, 16:30 |
Сообщение № 10

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, спасибо), тестирую. После подстановки путей с старта, наблюдается некторая полуторачасовая задумчивость. но данных много, для поиска, ожидаю.

 

Ответить

SLAVICK

Дата: Вторник, 15.12.2015, 19:06 |
Сообщение № 11

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290


Репутация:

766

±

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


2019

наблюдается некторая полуторачасовая задумчивость

ну судя из :

запустил копирование файлов ~200GB

— так и должно быть.
Если эта процедура многоразовая можно добавить вывод в статусную строку сколько % выполнено. А если на один раз то и так сойдет :D


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICKВторник, 15.12.2015, 19:07

 

Ответить

Данилкин

Дата: Среда, 16.12.2015, 14:15 |
Сообщение № 12

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, спасибо! Прекрасно отработала! Да и не полтора часа, в первый раз долго было потому что я цифры короткие не убрал ну и файлов конечно нашлось много. А для того чтобы файлы не скопировать, а переместить в этих строчках кода нужно команду заменить?
[vba]

Код

For i = 1 To UBound(ar)
For ii = 1 To UBound(f)
If f(ii) Like «*» & ar(i, 1) & «*» Then Copy_File f(ii), NewFol & Dir(f(ii))
Next ii, i
End Sub

[/vba]
[vba]

Код

Private Function Copy_File(ByVal sFileName As String, ByVal sNewFileName As String) As Boolean
Dim objFSO As Object
If sFileName = sNewFileName Then Exit Function
If Dir(sFileName, 16) = «» Then: Exit Function
If Not Dir(sNewFileName, 16) = «» Then Kill sNewFileName
Set objFSO = CreateObject(«Scripting.FileSystemObject»)
Call objFSO.CopyFile(sFileName, sNewFileName)
Copy_File = True
End Function

[/vba]
[moder]Оформляйте коды тегами!
Поправила на первый раз[/moder]

Сообщение отредактировал ManyashaСреда, 16.12.2015, 14:32

 

Ответить

SLAVICK

Дата: Среда, 16.12.2015, 19:22 |
Сообщение № 13

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290


Репутация:

766

±

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


2019

Попробуйте вместо
[vba]

Код

Call objFSO.CopyFile(sFileName, sNewFileName)

[/vba]
написать
[vba]

Код

Call objFSO.MoveFile(sFileName, sNewFileName)

[/vba]Вроде работает — если что завтра смогу проверить.


Иногда все проще чем кажется с первого взгляда.

 

Ответить

Данилкин

Дата: Вторник, 22.12.2015, 09:12 |
Сообщение № 14

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

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

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

4025460.xlsm
(51.4 Kb)

 

Ответить

SLAVICK

Дата: Вторник, 22.12.2015, 12:01 |
Сообщение № 15

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290


Репутация:

766

±

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


2019

Рад, что помогло :D
Проще всего добавить массив такой же размерности и там отмечать количество найденных:
[vba]

Код

Sub d()
Dim f(), i&, ii&, ar(), ar1(), fol$, NewFol$, coll As Collection
ar = [a2:a2471].Value ‘Selection.Value
ReDim ar1(1 To UBound(ar), 1 To 1)
fol = [c2]
NewFol = [d2]
Set coll = FilenamesCollection(fol)
ReDim f(1 To coll.Count)
For ii = 1 To coll.Count
f(ii) = coll(ii)
Next
For i = 1 To UBound(ar)
    For ii = 1 To UBound(f)
       If f(ii) Like «*» & ar(i, 1) & «*» Then Copy_File f(ii), NewFol & Dir(f(ii)): ar1(i, 1) = ar1(i, 1) + 1
Next ii, i
[b2].Resize(UBound(ar1), 1) = ar1
End Sub

[/vba]

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

7809360.xlsm
(54.1 Kb)


Иногда все проще чем кажется с первого взгляда.

 

Ответить

Данилкин

Дата: Понедельник, 28.12.2015, 10:56 |
Сообщение № 16

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

Ранг: Новичок

Сообщений: 13


Репутация:

0

±

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


Excel 2013

SLAVICK, урааа, спасибо, всё работает!!!

 

Ответить

Понравилась статья? Поделить с друзьями:
  • Поиск файла в папке vba excel
  • Поиск файла word по названию
  • Поиск уникальных значений в таблице excel
  • Поиск уникальных значений в массиве excel
  • Поиск уникальных значений в excel по условию