Пытался допилить код. Что-то получилось, что-то нет.
У меня вот так получилось: - сканирует заданную (фиксированную) в коде папку (очень долго собирает в папке на сервере. 1800 файлов.) - вставляет только имя (без расширения) и даты в указанный диапазон AP1:AR1/ колонки 42, 43, 44. - Вставка в ActiveWorksheet. / В Активный Лист /. Путь не выводит. Я его и так знаю. А вложенных папок нету.
Скрытый текст
Sub FileListNumbersH() ' Список файлов в папке Dim V As String Dim BrowseFolder As String BrowseFolder = "X:\BACKUP\PPR2017" 'BrowseFolder = CStr(V)
'добавляем лист и выводим на него шапку таблицы 'ActiveWorkbook.Sheets.Add With ActiveSheet.Range("AP1:AR1") .Name = "Calibri" .Font.Bold = True .Font.Size = 10 End With Range("AP1").Value = "Name" Range("AQ1").Value = "Created" Range("AR1").Value = "Modiefed"
'вызываем процедуру вывода списка файлов 'измените True на False, если не нужно выводить файлы из вложенных папок ListFilesInFolder BrowseFolder, True End Sub
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
Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.getfolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1 'находим первую пустую строку 'выводим данные по файлу For Each FileItem In SourceFolder.Files ' вставка в столбец 42, 43, 44 Cells(r, 42).Formula = Left(FileItem.Name, InStrRev(FileItem.Name, ".") - 1) ' имя файла БЕЗ расширения Cells(r, 43).Formula = FileItem.DateCreated Cells(r, 44).Formula = FileItem.DateLastModified r = r + 1 X = SourceFolder.Path Next FileItem
Columns("AQ:AR").AutoFit
Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing
Помогите с кодом, плиз. Что надо подправить, что бы выводить только последние 10 файлов? Последние по времени редактирования. Modified. Идеально, если это количество можно будет менять редактированием кода. Не могу найти мне понятных примеров в сети.
p.s. Отсекать лишнюю инфу в названии файла буду с помощью записанного макроса: "Ctr+H" + формула "=правсимв()"
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 файлов.
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
Вот только неожиданно долго он собирает информацию. 32секунды!!! Задумка была, что бы не открывать папку и не проверять номер последнего файла. А так получается что быстрее руками найти и проверить.
Где проблема? Проверял на Office 2007. Дома на 2016 посмотрю. ------------------------------------------------------------------------------------------------------- А вот на 2016 не сработало. Error 53/ File not found.
Подсветило жёлтым, начиная с двоеточия и до конца строки:
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
Использование функции 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
Максим Зеленский,в 2016 вставил Ваш код в запрос PQ. Создал запрос. Вывел данные на Лист. Поверхностно попробовал - работает вроде. Классная штука! Вот только на работе у меня установлен Office 2007.
Здравствуйте, Андрей! Я не вступал в соревнование, просто убрал в сообщении #7 ненужную там функцию dir, которая к тому же некорректно работает с именами файлов, не отображамых в кодовой таблице по умолчанию (Windows-1251).
Коллега, я не рассматриваю обсуждение как соревнование. Скорее как способ коллективно найти оптимальное решение при обсуждении темы всеми заинтересованными лицами. Плюс, чему-нибудь научиться. Просто в вашем коде проблема с методом сортировки пузырьком. Если у ТС 10000 файлов, то это будет долго 10000 * 10000 в среднем операций. Чтобы не писать Quick Sort я и предложил, раз нужно только ограниченное число файлов по дате, то тогда проще фильтровать их сразу по ходу дела. Для 10 нужных файлов и тех же 10000 в папке операций потребуется 20 * 10000, что быстрее.
Я полностью согласен с сообщением #17. В своих программах я не пользуюсь "пузырьком". Да, если вас заранее интересуют первые N записей результата, то алгоритмы меняются (например, в СУБД Oracle для этого есть специальный предикат rownum<=N).
Пример в сообщении #15, как обычно, оптимизирован замечательно.
Андрей 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
Нашёл. В VBA - References одна из библиотек имела пометку MISSING. Снял галку - вроде заработало.
Эта библиотека осталась от надстройки, которая была установлена на домашнем компе. А проблема возникла на рабочем компе, где эта надстройка не была установлена.
Правильно ли я понимаю : применив какую-то процедуру на компе С НАДСТРОЙКОЙ, в файл/-ы внедрилась какая-то инфа не работающая БЕЗ установленной этой надстройки? Подскажите плиз, где корень зла?