Хитрости »
Основные понятия (23)
Сводные таблицы и анализ данных (9)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (14)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (63)
Разное (38)
Баги и глюки Excel (2)

Собрать данные из файлов защищенных паролем PowerQuery

PowerQuery очень мощный инструмент по работе с файлами

Если еще не работали с надстройкой PowerQuery и не знаете что это такое, то для начала лучше ознакомиться со статьей: Power Query - что такое и почему её необходимо использовать в работе?

Наиболее часто она применяется для сбора данных с листов и файлов. Я для примеру возьму модель из своей статьи: Собрать и просуммировать данные из разных файлов при помощи PowerQuery. Там из папки отбираются все файлы Excel и объединяются в единую таблицу(плюс суммируются по критерию, но это сейчас неважно). Все работает отлично. Но если хотя бы на один файл будет установлен пароль на открытие запрос выдаст ошибку([DataFormat.Error] Внешняя таблица не имеет предполагаемый формат):
[DataFormat.Error] Внешняя таблица не имеет предполагаемый формат
а если перейти в редактор запроса, то там будет ошибка вроде такой - Невозможно импортировать данные из книги, защищенной паролем:
Невозможно импортировать данные из книги, защищенной паролем

чтобы избежать ошибки при обновлении надо держать файл без пароля, что не всегда допустимо. Особенно, когда речь идет о бюджетах и лежат они где-то на сетевом диске. Можно вручную открыть каждый файл, снять пароль, сохранить книгу, закрыть, обновить запрос, а затем установить пароль на все книги заново. Метод хоть и надежный, но совсем не быстрый, если книг с паролем в папке хотя бы 5-10.
Сама модель PowerQuery не умеет(пока что) работать с защищенными паролем файлами и не может снять пароль с книг. Но это можно сделать при помощи Visual Basic for Applications(VBA). При этом код не такой уж сложный сам по себе, но нам надо учесть три вещи:

  1. Папка с файлами должна определяться кодом автоматически из запроса. Здесь мы можем пойти хитрым путем и указывать путь в умной таблице(подробно про такой подход я описывал в статье: Относительный путь к данным PowerQuery). Тогда код так же сможет получить путь к папке просто из таблицы параметров. Это значит что и запрос PowerQuery и код VBA будут использовать один и тот же путь и это не потребует от нас особых усилий. Плюс модель можно будет перемещать куда угодно - а это тоже большой плюс
  2. Код должен сам сначала открыть все файлы, снять с них пароль, сохранить и закрыть. После этого обновить запрос и дождаться его выполнения
  3. И последним шагом код должен установить пароль на файлы обратно. И только после завершения обновления запроса, не раньше

Код просмотра файлов в папке я уже когда-то давно приводил на сайте: Просмотреть все файлы в папке. Нам останется его немного модифицировать и сделать из него функцию, которая будет на основании переданных в неё параметров либо снимать пароль, либо устанавливать. Впрочем, ниже готовый код, в котором достаточно комментариев, чтобы уловить суть:

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose:
'---------------------------------------------------------------------------------------
Option Explicit
 
Sub RefreshPQ()
    'вызываем функцию, убирающую пароль на открытие файлов
    Call ReOpenFiles(True, "1234")
    'обновляем все запросы в книге
    'если надо обновить только определенные
    '   -можно сделать это либо в одном конкретном листе
    '       (убрать цикл For Each ws In ThisWorkbook.Worksheets)
    '   -либо взять конкретный запрос(ws.QueryTables(1).Refresh)
    Dim ws As Worksheet, qt As QueryTable, oc As Object, IsBG_Refresh As Boolean
 
    For Each oc In ThisWorkbook.Connections
        'запоминаем значение обновления в фоне для запроса
        IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
        'выставляем принудительно ждать завершения запроса
        oc.OLEDBConnection.BackgroundQuery = False
        'обновляем запрос
        oc.Refresh
        'возвращаем обновление в фоне в первоначальное состояние
        oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh
    Next
''=======================================================
''   Если надо обновить только один запрос
'
'    set oc = ThisWorkbook.Connections("Запрос — Бюджет")
'    IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
'    oc.OLEDBConnection.BackgroundQuery = False
'    oc.Refresh
'    oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh
''=======================================================
 
    'вызываем функцию, чтобы поставить обратно пароль на файлы
    Call ReOpenFiles(False, "1234")
    MsgBox "Запросы обновлены", vbInformation, "www.excel-vba.ru"
End Sub
'функция открывает каждый файл в папке и удаляет/устанавливает пароль на открытие
Function ReOpenFiles(IsDelPWD As Boolean, sPWD As String)
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook
    Dim sNewPWD As String, sOldPWD As String
    'определяем, убрать пароль на открытие или вернуть
    If IsDelPWD Then
        sOldPWD = sPWD
        sNewPWD = ""
    Else
        sOldPWD = ""
        sNewPWD = sPWD
    End If
    'получаем путь к папке с файлами из "умной" таблицы "Parameters"(лист "Параметры")
    sFolder = Range("Parameters").Cells(1, 1).Value
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу, убирая/устанавливая пароль на открытие
        Set wb = Application.Workbooks.Open(sFolder & sFiles, False, Password:=sOldPWD)
        wb.Password = sNewPWD
        'закрываем книгу с сохранением
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Function

Процедура RefreshPQ содержит в себе основной код обновления запросов.
Функция ReOpenFiles - просматривает все файлы в папке(sFolder = Range("Parameters").Cells(1, 1).Value). Если аргумент IsDelPWD передан как True - то пароль с файлов снимается. Это мы делаем перед обновлением запроса. Если аргумент IsDelPWD передан как False - пароль на файлы устанавливается заново. Второй аргумент - это пароль на открытие файлов.
Почему в коде я применяю обновление всех запросов? Потому что я не знаю наверняка, только один запрос использует подключение к книгам или несколько. В смысле я-то точно знаю, что у меня такой запрос один. А вот один ли он будет всегда? Впрочем, в комментариях к коду я обозначил, что можно обновить один единственный запрос, если точно известно его имя(или номер):

'   Если надо обновить только один запрос
    set oc = ThisWorkbook.Connections("Запрос — Бюджет")
    IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
    oc.OLEDBConnection.BackgroundQuery = False
    oc.Refresh
    oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh

Конечно, у кого-то точно возникнет вопрос: а что если для каждого файла будет свой пароль? Это уже другая история и в таком случае оптимально создавать список всех файлов на отдельном листе, где записывать имя файла и пароль для него. А уже кодом при просмотре файлов из папки сравнивать имена и при совпадении применять нужный пароль. Хотя я не очень приветствую такой подход, потому что файлы, собираемые в единый отчет лучше и создавать одинаково, в том числе и пароль давать единый. Это впоследствии избавит от многих проблем.


Скачать готовую модель с рабочим кодом и всеми нужными ссылками:

  Модель сбора с защищенных файлов.zip (141,0 KiB, 73 скачиваний)


Т.к. сама PowerQuery просматривает файлы не только в одной указанной папке, но и во всех подпапках - решил дополнить статью кодом, который так же просматривает все файлы не только в указанной папке, но и во всех её подпаках до самой глубоко вложенной. Так же в этом коде реализовано запоминание пароля для каждой книги, если он был установлен. Это может пригодиться, если пароль на открытие установлен не на все книги, а только на некоторые. Предыдущий код в этом случае после первого выполнения устанавливал пароль на открытие на все книги в папке.

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose:
'---------------------------------------------------------------------------------------
Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim oPassDic As Object
Sub RefreshPQ()
    Set oPassDic = CreateObject("scripting.dictionary")
    oPassDic.comparemode = 1
 
    Application.StatusBar = "Снимаю пароль с файлов..."
    Application.DisplayAlerts = False 'чтобы не показывать окно пароля, если он неверный
    'вызываем функцию, убирающую пароль на открытие файлов
    Call ReOpenFilesFromSubFolders(True, "1234")
    'обновляем все запросы в книге
    'если надо обновить только определенные
    '   -можно сделать это либо в одном конкретном листе
    '       (убрать цикл For Each ws In ThisWorkbook.Worksheets)
    '   -либо взять конкретный запрос(ws.QueryTables(1).Refresh)
    Dim ws As Worksheet, qt As QueryTable, oc As Object, IsBG_Refresh As Boolean
    Application.StatusBar = "Обновляю запросы..."
    For Each oc In ThisWorkbook.Connections
        'запоминаем значение обновления в фоне для запроса
        IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
        'выставляем принудительно ждать завершения запроса
        oc.OLEDBConnection.BackgroundQuery = False
        'обновляем запрос
        oc.Refresh
        'возвращаем обновление в фоне в первоначальное состояние
        oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh
    Next
''=======================================================
''   Если надо обновить только один запрос
'
'    set oc = ThisWorkbook.Connections("Запрос — Бюджет")
'    IsBG_Refresh = oc.OLEDBConnection.BackgroundQuery
'    oc.OLEDBConnection.BackgroundQuery = False
'    oc.Refresh
'    oc.OLEDBConnection.BackgroundQuery = IsBG_Refresh
''=======================================================
 
    Application.StatusBar = "Устанавливаю пароль на файлы..."
    'вызываем функцию, чтобы поставить обратно пароль на файлы
    Call ReOpenFilesFromSubFolders(False, "1234")
    Set oPassDic = Nothing
    Application.StatusBar = False
    Application.DisplayAlerts = True
    MsgBox "Запросы обновлены", vbInformation, "www.excel-vba.ru"
End Sub
 
'функция открывает каждый файл в папке и всех подпапках
'   и удаляет/устанавливает пароль на открытие
'   если до этого на книгу не был установлен пароль - он не устанавливается
Function ReOpenFilesFromSubFolders(IsDelPWD As Boolean, sPWD As String)
    Dim sFolder As String
    'получаем путь к папке с файлами из "умной" таблицы "Parameters"(лист "Параметры")
    sFolder = Range("Parameters").Cells(1, 1).Value
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'просматриваем файлы в папке и всех подпапках
    GetSubFolders sFolder, IsDelPWD, sPWD
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Function
Private Function GetSubFolders(sPath, IsDelPWD As Boolean, sPWD As String)
    Dim sPathSeparator As String, sObjName As String
    Dim wb As Workbook
    Dim sNewPWD As String, sOldPWD As String, spass As String
    'определяем, убрать пароль на открытие или вернуть
    If IsDelPWD Then
        sOldPWD = sPWD
        sNewPWD = ""
    Else
        sOldPWD = ""
        sNewPWD = sPWD
    End If
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу, убирая/устанавливая пароль на открытие
            On Error Resume Next
            Set wb = Nothing
            Set wb = Application.Workbooks.Open(sPath & objFile.Name, False, Password:=sOldPWD)
            'если пароль подошел и книга открыта
            If Not wb Is Nothing Then
                If IsDelPWD Then
                    'запоминаем текущий пароль к книге, если он есть
                    If wb.HasPassword Then
                        spass = sOldPWD
                    Else
                        spass = ""
                    End If
                    oPassDic.Add wb.FullName, spass
                    wb.Password = ""
                Else
                    'устанавливаем пароль к книге, который был до этого
                    spass = oPassDic.Item(wb.FullName)
                    wb.Password = spass
                End If
                'закрываем книгу с сохранением
                wb.Close True 'если поставить False - книга будет закрыта без сохранения
            End If
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator, IsDelPWD, sPWD
    Next
End Function

Скачать модель обновления запроса и снятия пароля со всех файлов папки и подпапок:

  Модель сбора с защищенных файлов включая подпапки.zip (137,8 KiB, 64 скачиваний)


Кстати, функцию перебора файлов можно использовать отдельно и не только для снятия/установки пароля на открытие. Если чуть изменить, можно снимать пароли со всех листов всех книг. Для этого надо будет чуть изменить часть кода(надеюсь разберетесь какую часть надо заменить):

    Dim ws As Worksheet
    Do While sFiles <> ""
        'открываем книгу, убирая/устанавливая пароль на открытие
        Set wb = Application.Workbooks.Open(sFolder & sFiles, False, Password:=sOldPWD)
        wb.Password = sNewPWD
        For Each ws in wb.Worksheets
            If IsDelPWD Then
                ws.Unprotect Password:=sOldPWD
            Else
                ws.Protect Password:=sNewPWD
            End If
        Next
        'закрываем книгу с сохранением
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop

Так же см.:
Получить данные из файлов XML при помощи Power Query
Собрать и просуммировать данные из разных файлов при помощи PowerQuery
План-фактный анализ в Excel при помощи Power Query
Относительный путь к данным PowerQuery


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Outlook Power Query и Power BI VBA работа в редакторе VBA управление кодами Бесплатные надстройки Дата и время Диаграммы и графики Записки Защита данных Интернет Картинки и объекты Листы и книги Макросы и VBA Надстройки Настройка Печать Поиск данных Политика Конфиденциальности Почта Программы Работа с приложениями Работа с файлами Разработка приложений Сводные таблицы Списки Тренинги и вебинары Финансовые Форматирование Формулы и функции Функции Excel Функции VBA Ячейки и диапазоны акции MulTEx анализ данных баги и глюки в Excel ссылки
Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти
Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2018 Excel для всех   Войти