Список всех папок и подпапок и файлов подсчета

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

Он всегда сбой после выполнения значительного числа для записи. Кажется, что это не имеет ничего общего с пустыми папками (есть много тех, которые уже указаны как «0». Даже имя папки, с которой он падает, не является чем-то необычным. И это не обязательно сбой в той же папке каждый время, а не после того, как было записано заданное количество строк. Я попытался изменить порядок дисков в таблице, чтобы убедиться, что он всегда терпит неудачу на одном диске, но это не тот случай, он не работает во время первого диска. независимо от того, какой диск первый (T: \, R: \, S :). В какой-то момент он всегда сбой на коде «Filename = Dir (Mypath)». Он показывает имя файла как пустого, но Mypath показывает правильный путь тока.

Вот имя каталога, в котором он разбился в последний раз: «T: \ 05. Программа преобразования Cyber ​​и IT Security 03. Бизнес-документы и документы по стратегии», поэтому ничего необычного нет. Папка пуста, и ничего не скрыто. В свойствах установлены скрытые файлы, папки и т. Д.

Вот код:

Sub ListMyDir() 'This updates the tables in the "Starting Directory List" so they can be used in the drop down menus 'on the other worksheets to select a starting directory to list files from 'Setup display defaults ' Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual Application.DisplayStatusBar = True Application.StatusBar = "Importing Beehive Folder Names" 'Setup variables Dim tblrow As Integer Dim myIndexTable As ListObject Dim MyArray As Variant Dim MyArrayPath As String Dim MyLibraryName As String Dim x As Integer Dim y As Long Dim Folders As Integer Dim mfiles As Integer Dim mypath As String Set myIndexTable = ActiveSheet.ListObjects("EA_Libraries_Data") y = myIndexTable.ListRows.Count MyArray = myIndexTable.DataBodyRange MsgBox "Number of Libraries: " & y 'Set starting row number for table tblrow = 1 Folders = 1 myfiles = 0 ' On Error Resume Next 'Empty the existing table contents If ActiveSheet.ListObjects("EA_Directories").ListRows.Count > 0 Then ActiveSheet.ListObjects("EA_Directories").DataBodyRange.Delete End If 'Loop through list of tables For x = 1 To y 'Set the starting path and the Library Name from the array MyLibraryName = MyArray(x, 1) MyArrayPath = MyArray(x, 2) MsgBox "My Library: " & MyLibraryName & " Path: " & MyArrayPath & " Row: " & tblrow 'Call Subroutine for every instance of a new subfolder Call ListDirPath(MyArrayPath, MyLibraryName, tblrow, Folders, myfiles, mypath) Next x 'Sort Table Application.CutCopyMode = False ActiveWorkbook.Worksheets("Starting Directory List").ListObjects( _ "EA_Directories").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Starting Directory List").ListObjects( _ "EA_Directories").Sort.SortFields.Add Key:=Range( _ "EA_Directories[[#All],[Folder]]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Starting Directory List").ListObjects( _ "EA_Directories").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Application.ScreenUpdating = True Application.DisplayAlerts = True Application.StatusBar = "" Application.Calculation = xlCalculationAutomatic End Sub Sub ListDirPath(MyArrayPath, MyLibraryName, ByRef tblrow, ByRef Folders, ByRef myfiles, mypath) 'Get directory information Set MyObject = New Scripting.FileSystemObject Set mySource = MyObject.GetFolder(MyArrayPath) 'Add Path to table Application.StatusBar = "Importing Beehive Folder Names " & Folders ActiveSheet.ListObjects("EA_Directories").ListRows.Add AlwaysInsert:=True ActiveSheet.ListObjects("EA_Directories").DataBodyRange(tblrow, 1).Value = MyLibraryName ActiveSheet.ListObjects("EA_Directories").DataBodyRange(tblrow, 2).Value = MyArrayPath mypath = MyArrayPath & "\*.*" Filename = Dir(mypath) myfiles = 0 Do While Filename <> "" myfiles = myfiles + 1 Filename = Dir() Loop ActiveSheet.ListObjects("EA_Directories").DataBodyRange(tblrow, 3).Value = myfiles tblrow = tblrow + 1 Folders = Folders + 1 'Loop through all subdirectories If Error = 53 Then MsgBox Err & ": " & Error(Err) & "Path: " & MyArrayPath End If ' On Error Resume Next For Each MySubfolder In mySource.SubFolders Call ListDirPath(MySubfolder.Path, MyLibraryName, tblrow, Folders, myfiles, mypath) Next End Sub 

Мысли?

Interesting Posts

Обновление ссылок с защищенных паролем источников Excel

Открытие Excel в Word в режиме совместимости

Ошибка Excel 1004 Runtime при сортировке таблицы

Диаграмма столбцов с первичными и вторичными у-осями

Округление Excel VBA с удвоением

Формула Excel для увеличения числа

Как разместить тему форума с приложением к IBM Connections с помощью Excel VBA

нужна помощь в исправлении моего кода для отправки автоматических писем через vba

Отфильтруйте данные на другом листе с помощью расчета VBA

Как заполнить список столбцов с несколькими столбцами?

Проверьте, существуют ли два разных значения ячейки в одной строке и возвращают другой элемент из этой строки

Excel / Visual Studio / C #. Как изменить отображаемое имя ячейки, но сохранить формулу

Иконки условного форматирования жесткого кодирования в Excel для экспорта HTML

.xlsm файл открыт только для чтения

VBA – как я могу разделить диапазон ячеек фиксированной ячейкой

Давайте будем гением компьютера.