Получение файлов из архива ZIP на VBA

Sub ПримерИспользования()
    On Error Resume Next
    file$ = "D:\Проекты\Прайсы\Архив.zip"    ' путь к архиву, из которого будем извлекать файлы
    
    Dim coll As Collection
    Set coll = FilesFromZip(file)
    Debug.Print "Извлечено файлов: " & coll.Count ' выводи количество файлов
    
    For Each filename In coll ' выводим пути к извлечённым из архива ZIP файлам
        Debug.Print filename
    Next
End Sub

Function FilesFromZip(ByVal FileNameZip) As Collection
    ' Функция осуществляет распаковку архива с именем FileNameZip во временную папку
    ' (предварительно удаляя папку с таким именем, если она существует)
    ' Возвращает коллекцию, содержащую пути ко всем извлечённым из архива файлам)
    On Error Resume Next: Err.Clear: Set FilesFromZip = New Collection
 
    folder = Environ("tmp") & "\UNZIPPED FILES\"
    Shell "cmd /c rd /S/Q """ & folder & """"    ' удаляем папку
    DoEvents: DoEvents: DoEvents: DoEvents:
    MkDir folder    ' и создаём эту папку заново
    DoEvents: DoEvents: DoEvents: DoEvents: Err.Clear
 
    If Len(Dir(folder, vbDirectory)) = 0 Then Exit Function    ' не удалось создать папку
    If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
       vbCritical, "Ошибка в функции FilesFromZip": Exit Function
 
    Set oApp = CreateObject("Shell.Application")
    For Each it In oApp.Namespace(FileNameZip).Items: DoEvents: DoEvents:  Next
 
    oApp.Namespace(folder).CopyHere oApp.Namespace(FileNameZip).Items    'распаковываем файлы
    Set FilesFromZip = FilenamesCollection(folder, "*")
End Function

Function FileFromZip(ByVal FileNameZip) As String
    ' Функция осуществляет распаковку архива с именем FileNameZip во временную папку
    ' возвращает путь к разархивированному файлу Excel
     On Error Resume Next: Err.Clear
 
    folder = Environ("tmp") & "\UNZIP_" & Timer & "\"
    MkDir folder        ' и создаём эту папку заново

    If Len(Dir(folder, vbDirectory)) = 0 Then Exit Function        ' не удалось создать папку
    If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
       vbCritical, "Ошибка в функции FilesFromZip": Exit Function
 
    Set oApp = CreateObject("Shell.Application")
    For Each it In oApp.Namespace(FileNameZip).Items: DoEvents: DoEvents: Next
 
    oApp.Namespace(folder).CopyHere oApp.Namespace(FileNameZip).Items        'распаковываем файлы
    filename$ = folder & Dir(folder & "*.xls*", vbNormal)
    If Dir(filename$, vbNormal) Then FileFromZip = filename$
End Function