Код VBA для вывода списка всех файлов в папке, а также размеров изображения

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

1. Запись количества раз за каждую итерацию требует времени и ресурсов Excel. Таким образом, размещение возвращаемых значений в массивах и удаление их содержимого в конце сэкономит некоторое время.

2. Использование раннего связывания позволяет «компилятору выполнять важные оптимизации, которые обеспечивают более эффективные приложения. Объекты с ранним связыванием работают значительно быстрее, чем объекты с поздним связыванием, и делают ваш код более простым для чтения и обслуживания, точно указывая, какие объекты используются». Кроме того, вы также можете воспользоваться предложениями Intellisense... Посмотрите здесь, что заявляет Microsoft по этому вопросу.

А. Следующий фрагмент кода автоматически добавляет ссылку на «Элементы управления и автоматизацию Microsoft Shell»:

Private Sub addShell32Ref()
  'Microsoft Shell Controls and Automation`...
   On Error Resume Next
    ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\SysWOW64\Shell32.dll"
    If err.number = 32813 Then
        MsgBox "The reference already exists..."
    Else
        MsgBox "The reference added sucressfully..."
    End If
  On Error GoTo 0
End Sub

Б. Следующий адаптированный код использует два предложенных способа оптимизации скорости:

Sub Get_Properties_Men()
    'it needs a reference to 'Microsoft Shell Controls and Automation`...
    Dim oShell As Shell32.shell, oDir  As Shell32.Folder, sFile As Shell32.FolderItem
    
    Dim i As Long, arr1, arr2
    
    Set oShell = New Shell32.shell
    Set oDir = oShell.NameSpace("W:\Gegenpress Graphics\-- Crests Master\Clubs")
     
    ReDim arr1(1 To oDir.Items.count, 1 To 2) 'redim the array to keep the necessary data
    
    i = 1
    For Each sFile In oDir.Items
        arr1(i, 1) = sFile.Name
        arr1(i, 2) = sFile.ExtendedProperty("Dimensions")
        i = i + 1
    Next
    
    'you can use the same oShell object:
    Set oDir = oShell.NameSpace("W:\Gegenpress Graphics\-- Crests Master\Competitions")

    ReDim arr2(1 To oDir.Items.count, 1 To 2)
    i = 1
    For Each sFile In oDir.Items
        arr2(i, 1) = sFile.Name
        arr2(i, 2) = sFile.ExtendedProperty("Dimensions")
        i = i + 1
    Next
    
    'drop the loaded arrays content, at once:
    Range("A4").Resize(UBound(arr1), UBound(arr1, 2)).Value = arr1
    Range("D4").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
    
    MsgBox "Men's crests and competitions added."
End Sub

Не могу себе представить, насколько это увеличит скорость кода, но что-то наверняка даст...

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