Макрос для установки (замены) пароля на открытие, для все файлов Excel в заданной папке

Sub ChangePasswords()
    On Error Resume Next
    PassOld$ = shs.Range("PassOld").Text
    PassNew$ = shs.Range("PassNew").Text
 
    folder$ = GetFolder(777, True)        ' запрашиваем имя папки
    If folder$ = "" Then Exit Sub        ' выход, если пользователь отказался от выбора папки

    Dim coll As Collection
    ' считываем в колекцию coll имена файлов XLS*
    Set coll = FilenamesCollection(folder$, "*.xls*")
    If coll.Count = 0 Then
        MsgBox "В выбранной папке не найдено ни одного файла Excel", vbExclamation
        Exit Sub
    End If
 
    Dim WB As Workbook, nOK&, nErr&
    ' очистка таблицы ошибок
    Intersect(shs.UsedRange, shs.Range("b11:b" & shs.Rows.Count)).ClearContents
    Application.ScreenUpdating = False        ' отключаем обновление экрана

    For Each Filename In coll        ' перебираем найденные в папке файлы
        Err.Clear: Set WB = Nothing
        Set WB = Workbooks.Open(Filename, , , , PassOld$)        ' пробуем открыть очередной файл
        If Not WB Is Nothing Then        ' если файл открылся
            WB.Password = PassNew$        ' ставим новый пароль
            WB.Close True        ' закрываем файл с сохранением изменений
            nOK& = nOK& - (Err = 0)        ' считаем количество успешно сохранённых файлов

        Else        ' файл не открылся - выводим в список ошибок
            nErr& = nErr& + 1
            With shs.Range("b" & 10 + nErr&)
                .Value = Filename
                .Hyperlinks.Add .Resize(, 1), Filename, "", "Попробовать открыть файл вручную"
            End With
        End If
        DoEvents
    Next
 
    Application.ScreenUpdating = True
    msg$ = "Найдено файлов в папке: " & coll.Count & vbNewLine & _
           "Удалось заменить пароли на файлах: " & nOK&
    MsgBox msg, vbInformation, "Готово"
End Sub