Страницы: 1
RSS
Список файлов в папке. Как ограничить количество записей?, вывод списка файлов с условием по дате модификации/изменения
 
Добрый день!

На сайте есть такой топик: http://www.planetaexcel.ru/techniques/3/45/
Список файлов в папке - выводит на лист список файлов из указанной папки

Пытался допилить код. Что-то получилось, что-то нет.

У меня вот так получилось:
- сканирует заданную (фиксированную) в коде папку (очень долго собирает в папке на сервере. 1800 файлов.)
- вставляет только имя (без расширения) и даты в указанный диапазон AP1:AR1/ колонки 42, 43, 44.
- Вставка в ActiveWorksheet
. / В Активный Лист /. Путь не выводит. Я его и так знаю.  8) А вложенных папок нету.

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

Помогите с кодом, плиз.
Что надо подправить, что бы выводить только последние 10 файлов?  Последние по времени редактирования. Modified. Идеально, если это количество можно будет менять редактированием кода.
Не могу найти мне понятных примеров в сети.

p.s. Отсекать лишнюю инфу в названии файла буду с помощью записанного макроса: "Ctr+H" + формула "=правсимв()"
Изменено: jack_21 - 07.11.2017 23:23:15 (грамматика)
 
Попробуйте так:
Код
Sub GetLast10Files()
    Dim i As Long, p As String, f As String, a(), fso
    Application.ScreenUpdating = False: [AP:AR].Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = "X:\BACKUP\PPR2017\"                            'Папка с файлами (и разделителем)
    ReDim a(1 To fso.GetFolder(p).Files.Count, 1 To 3)
    f = Dir(p & "*.xls*")
    Do While f <> ""
        i = i + 1
        a(i, 1) = fso.GetBaseName(p & f)                'Имя файла без расширения
        a(i, 2) = fso.GetFile(p & f).Size               'Размер файла
        a(i, 3) = fso.GetFile(p & f).DateLastModified   'Дата последней модификации
        f = Dir
    Loop
    [AP1].Resize(UBound(a, 1), UBound(a, 2)).Value = a  'Выгружаем на активный лист
    [AP:AR].Sort [AR1], xlDescending, Header:=xlNo      'Сортируем по дате
    Range("AP11:AR" & Rows.Count).ClearContents         'Оставляем первые 10 файлов
End Sub
Форматирование полученной таблицы добавьте самостоятельно.
Если принципиально, то можно отсортировать строки внутри массива и выгружать на лист не весь массив, а только последние (по дате) 10 файлов.
Изменено: SAS888 - 08.11.2017 07:48:29
Чем шире угол зрения, тем он тупее.
 
Нет. Не работает.

error 53 - File not found
Подсветил жёлтым 11ую строку:  

a(i, 2) = fso.GetFile(p & f).Size
 
Цитата
SAS888 написал:
выгружать на лист не весь массив, а только последние (по дате) 10 файлов.
Ну да. Именно так и хотел... Выгружать только последние 10.
 
Проверяйте
Код
Sub GetLast10Files()
    Dim i As Long, j As Long, k As Long, p As String, f As String, a(), fso, x
    Application.ScreenUpdating = False: [AP:AR].Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = "X:\BACKUP\PPR2017\"                   'Папка с файлами (и разделителем)
    ReDim a(1 To fso.GetFolder(p).Files.Count, 1 To 3)
    f = Dir(p & "*.xls*")
    Do While f <> ""
        i = i + 1: Set x = fso.GetFile(p & f)
        a(i, 1) = fso.GetBaseName(p & f)        'Имя файла без расширения
        a(i, 2) = x.Size                        'Размер файла
        a(i, 3) = x.DateLastModified            'Дата последней модификации
        f = Dir
    Loop
'''''''''''''''Сортировка массива по дате''''''''''''''''''''''''''''''''''''''''''''''''
    For i = 1 To UBound(a, 1) - 1
        For j = i + 1 To UBound(a, 1)
            If a(i, 3) < a(j, 3) Then
                For k = 1 To UBound(a, 2)
                    x = a(i, k): a(i, k) = a(j, k): a(j, k) = x
    Next: End If: Next: Next
'''''''''''Выгружаем на активный лист последние по дате 10 файлов''''''''''''''''''''''''
    i = IIf(UBound(a, 1) < 10, UBound(a, 1), 10)
    [AP1].Resize(i, 3).Value = a
End Sub
Изменено: SAS888 - 09.11.2017 05:13:57
Чем шире угол зрения, тем он тупее.
 
Огромное спасибо. "Сработала дудочка" (с)

Вот только неожиданно долго он собирает информацию. :(  32секунды!!!
Задумка была, что бы не открывать папку и не проверять номер последнего файла. А так получается что быстрее руками найти и проверить. :(

Где проблема? Проверял на Office 2007. Дома на 2016 посмотрю.
-------------------------------------------------------------------------------------------------------
А вот на 2016 не сработало. :(
Error 53/ File not found.

Подсветило жёлтым, начиная с двоеточия и до конца строки:
Код
  i = i +1 : Set x = fso.GetFile(p & f)
Изменено: jack_21 - 26.03.2018 16:31:29
 
1. Большое время сбора информации, скорее всего, связано не с макросом, а с медленным доступом к сетевому диску.
2. Почему метод fso.GetFile выдает ошибку в Excel 2016 не знаю (не могу протестировать). Но можно этот метод вообще не использовать. Например так:
Код
Sub GetLast10Files()
    Dim i As Long, j As Long, k As Long, p As String, f As String, a(), fso, x
    Application.ScreenUpdating = False: [AP:AR].Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = "X:\BACKUP\PPR2017\"                   'Папка с файлами (и разделителем)
    ReDim a(1 To fso.GetFolder(p).Files.Count, 1 To 3)
    f = Dir(p & "*.xls*")
    Do While f <> ""
        i = i + 1
        a(i, 1) = fso.GetBaseName(p & f)        'Имя файла без расширения
        a(i, 2) = FileLen(p & f)                'Размер файла
        a(i, 3) = FileDateTime(p & f)           'Дата последней модификации
        f = Dir
    Loop
'''''''''''''''Сортировка массива по дате''''''''''''''''''''''''''''''''''''''''''''''''
    For i = 1 To UBound(a, 1) - 1
        For j = i + 1 To UBound(a, 1)
            If a(i, 3) < a(j, 3) Then
                For k = 1 To UBound(a, 2)
                    x = a(i, k): a(i, k) = a(j, k): a(j, k) = x
    Next: End If: Next: Next
'''''''''''Выгружаем на активный лист последние по дате 10 файлов''''''''''''''''''''''''
    i = IIf(UBound(a, 1) < 10, UBound(a, 1), 10)
    [AP1].Resize(i, 3).Value = a
End Sub
Чем шире угол зрения, тем он тупее.
 
На 2007 работает. Время = 25 сек.
Вечером проверю на 2016.
 
Power Query не подойдет?
Код
let
    Source = Folder.Contents("путь к папке"),
    Sorted = Table.Sort(Source,{{"Date modified", Order.Descending}}),
    KeptFirstRows = Table.FirstN(Sorted,10),
    RemovedOtherColumns = Table.SelectColumns(KeptFirstRows,{"Name", "Date modified"})
in
    RemovedOtherColumns
F1 творит чудеса
 
Использование функции dir в сообщениях #5 и #7 излишне, так как коллекция files уже содержит информацию о всех файлах папки p. Вероятно, использование этой же функции и приводит к ошибке, указанной в сообщении #6. Вариант без dir:


Код
Sub GetLast10Files()
    Dim i As Long, j As Long, k As Long, p As String, f, a(), fso, files
    Application.ScreenUpdating = False: [AP:AR].Clear
    Set fso = CreateObject("Scripting.FileSystemObject")
    p = "X:\BACKUP\PPR2017\"                   'Папка с файлами (и разделителем)
    Set files = fso.GetFolder(p).files
    ReDim a(1 To files.Count, 1 To 3)
    For Each f In files
        If LCase(f.Name) Like "*.xls*" Then
          i = i + 1
          a(i, 1) = f.Name                        'Имя файла без расширения
          a(i, 2) = f.Size                        'Размер файла
          a(i, 3) = f.DateLastModified            'Дата последней модификации
        End If
    Next f
'''''''''''''''Сортировка массива по дате''''''''''''''''''''''''''''''''''''''''''''''''
    For i = 1 To UBound(a, 1) - 1
        For j = i + 1 To UBound(a, 1)
            If a(i, 3) < a(j, 3) Then
                For k = 1 To UBound(a, 2)
                    x = a(i, k): a(i, k) = a(j, k): a(j, k) = x
    Next: End If: Next: Next
'''''''''''Выгружаем на активный лист последние по дате 10 файлов''''''''''''''''''''''''
    i = IIf(UBound(a, 1) < 10, UBound(a, 1), 10)
    Range("AP1").Resize(i, 3).Value = a
    Set files = Nothing: Set fso = Nothing
End Sub
Изменено: sokol92 - 10.11.2017 13:24:53
Владимир
 
Цитата
Максим Зеленский написал:
Power Query не подойдет?
Упс!  8-0  Я так понимаю, у меня в системе (или в голове?) чего-то не хватает... Вставить через Insert - Module не получается. Всё красным светится.
 
Цитата
sokol92 написал:
Вариант без dir:
На 2007 сработало. Ошибки нету. 90 сек.
 
Цитата
jack_21 написал:
Вставить через Insert - Module не получается.
это не VBA :)
но на 2007 работать не будет.
на 2010 и 2013 нужна надстройка Power Query для Excel.
В 2016 она уже встроена в Excel
F1 творит чудеса
 
Максим Зеленский,в 2016 вставил Ваш код в запрос PQ.
Создал запрос. Вывел данные на Лист.
Поверхностно попробовал  - работает вроде. Классная штука! Вот только на работе у меня установлен Office 2007. :(
Изменено: jack_21 - 10.11.2017 23:55:37
 
Доброе время суток
Цитата
jack_21 написал:
Вот только неожиданно долго он собирает информацию.
Сколько у вас там файлов?
Вариант.
Успехов.
P. S. sokol92, если нужны только 10 файлов, то зачем формировать данные по всем файлам?
Изменено: Андрей VG - 11.11.2017 10:05:07 (Переделал ожидание завершения формирования списка файлов)
 
Здравствуйте, Андрей! Я не вступал  в соревнование, просто убрал в сообщении #7 ненужную там функцию dir, которая к тому же некорректно работает с именами файлов, не отображамых в кодовой таблице по умолчанию (Windows-1251).
Владимир
 
Цитата
sokol92 написал:
Я не вступал  в соревнование
Коллега, я не рассматриваю обсуждение как соревнование. Скорее как способ коллективно найти оптимальное решение при обсуждении темы всеми заинтересованными лицами. Плюс, чему-нибудь научиться.
Просто в вашем коде проблема с методом сортировки пузырьком. Если у ТС 10000 файлов, то это будет долго 10000 * 10000 в среднем операций. Чтобы не писать Quick Sort я и предложил, раз нужно только ограниченное число файлов по дате, то тогда проще фильтровать их сразу по ходу дела. Для 10 нужных файлов и тех же 10000 в папке операций потребуется 20 * 10000, что быстрее.
 
Я полностью согласен с сообщением #17. В своих программах я не пользуюсь "пузырьком". Да, если вас заранее интересуют первые N записей результата, то алгоритмы меняются (например, в СУБД Oracle для этого есть специальный предикат rownum<=N).

Пример в сообщении #15, как обычно, оптимизирован замечательно.
Изменено: sokol92 - 11.11.2017 10:46:46
Владимир
 
Цитата
Андрей VG написал:
Сколько у вас там файлов?
1800...2500. В сетевой папке. Все файлы Excel-овские... xls xlsx.
 
[USER=55]Андрей VG, переместив модуль из вашего файла в свою книгу макросов, он перестал работать...

"User-defined type not defined" для строки
Private Sub updateOut(ByVal thisFile As Shell32.FolderItem)
Изменено: jack_21 - 11.11.2017 23:01:22
 
Цитата
jack_21 написал:
User-defined type not defined
Подключите библиотеку Microsoft Shell Controls And Automation
 
Подключил. Заработало.
Изменено: jack_21 - 14.11.2017 18:02:19
 
Андрей VG, Протестировал на работе. Практически мгновенное срабатывание в случае сканирования сетевой папки...  
На разных компах время слегка разнится - от 0,5сек до 4 сек.
 
Не могу разобраться, какую часть кода надо  повесить на кнопку, чтобы это заработало с кнопки в UserForm. Подскажите, пожалуйста...

Код
Option Explicit
Private Const LastFileCount As Long = 10 ' количество выгружаемых записей
Private outData() As Variant

Public Sub FindLastPPR()
    Dim neededFiles As Shell32.FolderItems3
    Dim nextFile As Shell32.FolderItem
    Set neededFiles = GetFiles("F:\!!!_BACKUP-PP\PAVADZIMES\2017", "*.*") ' C:\Windows\System32
    Init
    For Each nextFile In neededFiles
        updateOut nextFile
    Next
    ActiveSheet.Range("AR2").Resize(LastFileCount, 3).Value = outData ' выгрузка в /ActiveSheet.Range("AR2")/
End Sub

Private Sub updateOut(ByVal thisFile As Shell32.FolderItem)
    Dim pos As Long, i As Long, fileDate As Date
    fileDate = thisFile.ModifyDate
    pos = -1
    For i = 1 To LastFileCount
        If outData(i, 1) < fileDate Then
            pos = i
            Exit For
        End If
    Next
    If pos > -1 Then
        For i = LastFileCount - 1 To pos Step -1
            outData(i + 1, 1) = outData(i, 1)
            outData(i + 1, 2) = outData(i, 2)
            'outData(i + 1, 3) = outData(i, 3)
        Next
        outData(pos, 1) = fileDate ' fileDate
        outData(pos, 2) = thisFile.Name
        'outData(pos, 3) = thisFile.Size
    End If
End Sub

Private Sub Init()
    Dim i As Long, startDate As Date
    ReDim outData(1 To LastFileCount, 1 To 3)
    For i = 1 To LastFileCount
        outData(i, 1) = startDate
    Next
End Sub

Private Function GetFiles(ByVal initPath As String, ByVal fileFilter As String) As Shell32.FolderItems3
    Dim pShell As New Shell32.Shell
    Dim pFolder As Shell32.Folder3
    Dim pItems As Shell32.FolderItems3
    Dim curCount As Long
    Set pFolder = pShell.Namespace(initPath)
    Set pItems = pFolder.Items
    curCount = 0
    pItems.Filter &H40, fileFilter
    Do Until pItems.Count = curCount
        curCount = pItems.Count
        Application.Wait CDate(CDbl(Time) + 1.15740740740741E-05)
    Loop
    Set GetFiles = pItems
    Set pFolder = Nothing
    Set pShell = Nothing
End Function



Оригинал в посте №15
Изменено: jack_21 - 09.12.2017 13:21:22
 
Неожиданно возникла ошибка.
Compile error: Can't find project or library
и подсвечивает Time v этой строке:
Код
Application.Wait CDate(CDbl(Time) + 1.15740740740741E-05)

Чего ему вдруг стало не хватать? Чего надо подключить?
 
Нашёл. В VBA - References одна из библиотек имела пометку MISSING. Снял галку - вроде заработало.

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

Правильно ли я понимаю :
применив какую-то процедуру на компе С НАДСТРОЙКОЙ, в файл/-ы внедрилась какая-то инфа не работающая БЕЗ установленной этой надстройки?
Подскажите плиз, где корень зла?

HOME = w8.1x64 + mso2010
WORK = w8.1x64 + mso2007
Изменено: jack_21 - 27.03.2018 08:54:57
 
Читаем про "раннее и позднее связывание" (у Вас в примере раннее).
Владимир
Страницы: 1
Наверх