Забыли пароль?


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

Как получить данные из закрытой книги?

Достаточно часто появляется вопрос: как извлечь данные из закрытой книги Excel через VBA? Звучит может быть странновато, но это так: вопрос регулярно поднимается на форумах. Собственно, именно в связи с этим и появилась на свет данная статья. В принципе ничего сложного в задаче нет. При этом получить данные можно разными способами, в том числе при помощи функций пользователя(UDF).
Попробуем разобраться с некоторыми методами, их плюсами и минусами.

Получение данных из закрытой книги из процедуры

Sub Get_Value_From_Close_Book_Formula()
    Dim sPath As String, sFile As String, sShName As String
    sPath = "C:\Documents and Settings\" '"
    sFile = "Книга1.xls" '"
    sShName = "Лист1" '"
    Application.DisplayAlerts = 0
    With Range("A1:A100")
        .Formula = "='" & sPath & "[" & sFile & "]" & sShName & "'!" & "A1" '"
        '"A1" - указывается начальная ячейка диапазона, из которого необходимо получить значения
        .Value = .Value
    End With
    Application.DisplayAlerts = 1
End Sub

Данный код работает достаточно медленно, но с его помощью можно "вытащить" из закрытой книги значения сразу нескольких ячеек. Код ниже работает быстрее, но с его помощью можно извлечь значения лишь одной ячейки:

Sub Get_Value_From_Close_Book_Excel4Macro()
    Dim sPath As String, sFile As String, sShName As String
    Dim sAddress As String, vData
    sPath = "C:\Documents and Settings\" '"
    sFile = "Книга1.xls" '"
    sShName = "Лист1" '"
 
    sAddress = "'" & sPath & "[" & sFile & "]" & sShName & "'!" & Range("A1").Address(ReferenceStyle:=xlR1C1) '"
    vData = ExecuteExcel4Macro(sAddress)
End Sub

Если честно, сам я не очень-то люблю ни один из данных методов, т.к. они совершенно лишены гибкости. С их помощью можно получить исключительно значения ячеек. Форматы, формулы или другие свойства ячеек получить уже не получится. Поэтому я предпочитаю открывать книгу и копировать то, что мне надо. Делаю это, скрывая от пользователя при помощи свойства ScreenUpdating объекта Application.

Sub Get_Value_From_Close_Book()
    Dim sShName As String, sAddress As String, vData
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Workbooks.Open "C:\Documents and Settings\Книга1.xls" '"
    sAddress = "A1:C100" 'или одна ячейка - "A1"
    'получаем значение
    vData = Sheets("Лист1").Range(sAddress).Value
    ActiveWorkbook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
    'если надо копировать ячейки с форматами, 
    'то можно использовать стандартные методы копирования вставки
    'objCloseBook.Sheets("Лист1").Range(sAddress).Copy
    '[A1].PasteSpecial xlPasteValues  'вставляем значения
    '[A1].PasteSpecial xlPasteFormats 'вставляем форматы
    'Включаем обновление экрана
    Application.ScreenUpdating = True
End Sub

Есть и более экзотический метод - при помощи GetObject:

Sub Get_Value_From_Close_Book2()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Documents and Settings\Книга1.xls")
    sAddress = "A1:C100" 'или одна ячейка - "A1"
    'получаем значение
    vData = objCloseBook.Sheets("Лист1").Range(sAddress).Value
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
    'если надо копировать ячейки с форматами, 
    'то можно использовать стандартные методы копирования вставки
    'objCloseBook.Sheets("Лист1").Range(sAddress).Copy
    '[A1].PasteSpecial xlPasteValues  'вставляем значения
    '[A1].PasteSpecial xlPasteFormats 'вставляем форматы
    'Включаем обновление экрана
    Application.ScreenUpdating = True
End Sub

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


Получение данных из закрытой книги при помощи UDF
Тот же код, что уже был рассмотрен выше, но оформленный в виде UDF(функции пользователя):

Function Get_Value_From_Close_Book(sWb As String, sShName As String, sAddress As String)
    Dim vData, objCloseBook As Object
    Set objCloseBook = GetObject(sWb)
    'получаем значение
    vData = objCloseBook.Sheets(sShName).Range(sAddress).Value
    objCloseBook.Close False
    'Возвращаем данные в ячейку с функцией
    Get_Value_From_Close_Book = vData
End Function

Синтаксис функции (вызов с листа):
=Get_Value_From_Close_Book("C:\Книга1.xls";"Лист1";"B1")
sWb - полный путь до книги, данные из которой необходимо извлечь ("C:\Книга1.xls")
sShName - имя листа в указанной книге, данные из которого необходимо извлечь ("Лист1")
sAddress - адрес ячейки(диапазона) данные которой необходимо получить ("B1")

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


ПОЛУЧЕНИЕ ДАННЫХ ПРИ ПОМОЩИ ADO
Так же есть еще один достаточно экзотический метод получения данных из действительно закрытой книги - через ADO(ActiveX Data Objects). По сути это получение данных через запрос SQL, используя для этого технологию ADO.

'---------------------------------------------------------------------------------------
' Procedure : Extract_Value_ADO
' DateTime  : 02.07.2014 16:47
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Функция получения данных из закрытой книги при помощи ADO
'             в таком виде не может быть использована вызовом с листа
'---------------------------------------------------------------------------------------
Function Extract_Value_ADO(sPath As String, sFileName As String, sShName As String, sRng As String)
    Dim objADO_Con As Object, objRS As Object
    Dim sFullFileName As String, sADORng As String
 
    'проверяем наличие слеша в пути к файлу
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    'если ячейка только одна - меняем вид адресации на ячейка:ячейка, как того требует ADO
    If Range(sRng).Count = 1 Then
        sADORng = sRng & ":" & sRng
    Else
        sADORng = sRng
    End If
    sFullFileName = sPath & sFileName
    With CreateObject("ADODB.Connection")
        'подключаемся к файлу
        .Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=1;DBQ=" & sFullFileName & ";"
        'извлекаем записи из указанного диапазона в objRS
        Set objRS = .Execute("select * FROM [" & sShName & "$" & sADORng & "]")
        'выгружаем извлеченные данные на активный лист, начиная с ячейки А1
        Cells(1, 1).CopyFromRecordset objRS
        'Extract_Value_ADO = objRS.Fields(0).Value
    End With
    Set objRS = Nothing
End Function

Вызывать эту функцию следует из другой процедуры или функции. Пример процедуры, для вызова этой функции:

'---------------------------------------------------------------------------------------
' Procedure : Get_Value_From_Close_Book_ADO
' Purpose   : Вызов функции Extract_Value_ADO
'---------------------------------------------------------------------------------------
Sub Get_Value_From_Close_Book_ADO()
    Extract_Value_ADO ThisWorkbook.path, "Книга1.xls", "Лист1", "A1:B25"
End Sub

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

Cells(1, 1).CopyFromRecordset objRS

на такую:

Extract_Value_ADO = objRS.Fields(0).Value

Синтаксис вызова с листа в таком случае будет следующим:
=Extract_Value_ADO("C:\"; "Книга1.xls"; "Лист1"; "A1")
Важно: если данные извлекаются только из одной ячейки, то следует указать две ячейки: А1:А2. Это особенность работы с запросами

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

'---------------------------------------------------------------------------------------
' Procedure : Extract_Value_ADO
' DateTime  : 02.07.2014 16:47
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Функция получения данных из закрытой книги при помощи ADO
'             вызывается с листа как функция массива(если получаем данные с диапазона)
'---------------------------------------------------------------------------------------
Function Extract_Value_ADO_Sh(sPath As String, sFileName As String, sShName As String, sRng As String)
    Dim objADO_Con As Object, objRS As Object
    Dim sFullFileName As String, sADORng As String
    Dim avTmp(), avRes(), li As Long, lr As Long, lc As Long
    'проверяем наличие слеша в пути к файлу
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    'если ячейка только одна - меняем вид адресации на ячейка:ячейка, как того требует ADO
    If Range(sRng).Count = 1 Then
        sADORng = sRng & ":" & sRng
    Else
        sADORng = sRng
    End If
    sFullFileName = sPath & sFileName
    With CreateObject("ADODB.Connection")
        'подключаемся к файлу
        .Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=1;DBQ=" & sFullFileName & ";"
        'получаем кол-во строк в запросе
        Set objRS = .Execute("SELECT COUNT(*) FROM [" & sShName & "$" & sADORng & "]")
        li = objRS.Fields(0).Value
        'извлекаем записи из указанного диапазона в objRS
        Set objRS = .Execute("SELECT * FROM [" & sShName & "$" & sADORng & "]")
        'выгружаем извлеченные данные на активный лист, начиная с ячейки А1
        ReDim avRes(1 To li, 1 To objRS.Fields.Count)
        avTmp = objRS.getrows(li, 0)    'получаем массив данных запроса
        For lr = 0 To li - 1    'цикл по строкам
            For lc = 0 To UBound(avTmp, 1) 'цикл по столбцам
                'значения Null не допускаются, поэтому приходится их подменять до выгрузки на лист
                If IsNull(avTmp(lc, lr)) Then
                    avTmp(lc, lr) = Empty
                End If
                avRes(lr + 1, lc + 1) = avTmp(lc, lr)
            Next lc
        Next lr
    End With
 
    Extract_Value_ADO_Sh = avRes
    Set objRS = Nothing
End Function

Синтаксис вызова с листа точно такой же как и в функции выше, только нужно будет выделить необходимое количество ячеек и ввести в них эту функцию, как формулу массива.:
=Extract_Value_ADO_Sh("C:\"; "Книга1.xls"; "Лист1"; "A1:B10")
sPath - путь к папке с книгой, данные из которой необходимо извлечь ("C:\")
sWb - имя книги, включая расширение(.xls в примере), данные из которой необходимо извлечь ("Книга1.xls")
sShName - имя листа в указанной книге, данные из которого необходимо извлечь ("Лист1")
sAddress - адрес ячейки(диапазона) данные которой необходимо получить ("A1")
Важно: если данные извлекаются только из одной строки, то следует все равно указать минимум две строки: А1:B10. Это особенность работы с запросами. При попытке указать только одну строку А1:A10 функция вернет значение ошибки. При этом первая строка воспринимается как заголовки. Т.е. данные должны начинаться как минимум со второй строк(A2), а в A1 - заголовок
Хоть эта функция имеет определенные недостатки - она может быть в разы быстрее предыдущей.


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

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

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

  2. Денис:

    У меня получилось. Правда немного по другому сделал.
    Workbooks.Open "D:\2.xls", False, False

    iLastRow2 = Cells(Rows.Count, "D").End(xlUp).Row

    sAddress = "A3:D" & iLastRow2

    Set vData = Sheets("Лист1").Range(sAddress)

    Workbooks("1.xls").Activate

    vData.Copy Range("P3")

    Workbooks("2.xls").Close False, False

    Спасибо Вам за совет.

  3. Миха:

    Пытаюсь воспользоваться методом ПОЛУЧЕНИЕ ДАННЫХ ПРИ ПОМОЩИ ADO при запуске макроса вылетает ошибка:
    [Microsoft][Драйвер ODBC EXCEL] Обновление не возможно. База данных или объект доступны только для чтения
    Подскажите, каким образом ее исправить? код у меня такой вот:

    Sub Get_Value_From_Close_Book_ADO()
        Extract_Value_ADO "Лист1", "K5:K22"
    End Sub
     
    Function Extract_Value_ADO(sShName As String, sRng As String) 'sPath As String, sFileName As String, sShName As String, sRng As String
        Dim objADO_Con As Object, objRS As Object
        Dim sFullFileName As String, sADORng As String
        sPath = ИмяФайла
     
        'If Right(sPath, 1)  "" Then sPath = sPath & ""
     
        If Range(sRng).Count = 1 Then
            sADORng = sRng & ":" & sRng
        Else
            sADORng = sRng
        End If
        sFullFileName = Chr(34) & sPath & Chr(34)
        With CreateObject("ADODB.Connection")
     
            .Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=0;DBQ=" & sFullFileName & ";"
     
            Set objRS = .Execute("select * FROM [" & sShName & "$" & sADORng & "]")
     
            Range(Cells(Строка, 97), Cells(Строка, 115)).CopyFromRecordset objRS
            'Extract_Value_ADO = objRS.Fields(0).Value
        End With
        Set objRS = Nothing
    End Function

    "ИмяФайла" и "Строка" переменные получаемые раньше

    • Попробуйте изменить значение ReadOnly=0 на ReadOnly=1.
      И подскажите - откуда Вы взяли вот это:

      sFullFileName = Chr(34) & sPath & Chr(34)

      у меня такого нет. И в таком виде не уверен, что запрос будет работать - лишние кавычки не всегда к месту...

  4. Миха:

    а при попытке получить данные способом №3 они копируются не в строку как мне надо а в столбец... Прошу помощи в исправлении кода:

    Sub Get_Value_From_Close_Book()
        Dim sShName As String, sAddress As String, vData
        'Отключаем обновление экрана
        Application.ScreenUpdating = False
        Workbooks.Open ИмяФайла
        sAddress = "K5:K22" 'или одна ячейка - "A1"
        'получаем значение
        vData = Sheets("Лист1").Range(sAddress).Value
        ActiveWorkbook.Close False
        'Записываем данные на активный лист книги,
        'с которой запустили макрос
        If IsArray(vData) Then
            Range(Cells(Строка, 97), Cells(Строка, 115)).Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
        Else
            Range(Cells(Строка, 97), Cells(Строка, 115)) = vData
        End If
        'Включаем обновление экрана
        Application.ScreenUpdating = True
    End Sub
    • Наверное, прежде чем менять наобум надо было справку по методу Resize открыть :-)

      Cells(Строка, 97).Resize(UBound(vData, 2), UBound(vData, 1)).Value = vData

      или вовсе без него(все равно фиксированно указываете диапазон:

      Range(Cells(Строка, 97), Cells(Строка, 115)).Value = vData

      Плюс совершенно непонятно, почему в блок Else Вы так же впихиваете запись возвращаемого значения в диапазон. Ведь значение-то - только одно...

  5. Миха:

    Все верно. в функции Extract_Value_ADO кавычки в пути действительно оказались лишними. прописал в коде просто путь к файлу:
    sPath = ИмяФайла
    и все заработало.
    Однако обнаружилась та же проблема что у меня возникла при попытке выдернуть данные способом №3, а именно с закрытой книги я пытаюсь вытянуть данные из ячеек столбца "К" в определенном диапазоне строк (с 5 по 22) и вставить их в ячейки строки "СТРОКА" в диапазоне столбцов с 97 по 115. В результате работы макроса я получаю заполненные ячейки столбца 97 в диапазоне "СТРОКА" - "СТРОКА+22"....
    Можете подсказать возможно ли получить требуемый результат? Или проще получить данные столбеца в дополнительный лист, а потом заполнить нужную мне строку?

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

      Range(Cells(Строка, 97), Cells(Строка, 115)).Value = Application.Transpose(vData)

      или перед выгрузкой массива транспонировать его в цикле.

      Однако, если мы говорим про ADO - то Вам надо изменить цикл внутри самой функции, т.к. запрос изначально возвращает данные в нужном Вам виде, но в цикле я ответ транспонирую в верную структуру данных(как они выглядят в источнике).

      Либо тот же подход, что выше:

      Extract_Value_ADO_Sh = Application.Transpose(avRes)
  6. Миха:

    Огромное Вам спасибо. Наконец-то я разобрался благодаря вашим подсказкам!

  7. Ника:

    Здравствуйте! При использовании первого способа как быть, если расположение файла не постоянное. Надо чтобы файл подхватывал значения из книги, лежащей с ней в одной папке. Заранее спасибо

  8. VictorM:

    Здравствуйте.
    Применил Ваш "экзотический метод - при помощи GetObject" все отлично работает.
    Этот же код решил применить и для записи данных в закрытую книгу.
    Все сработало отлично. Но...одно но появилось. При сохранении книги как
    objCloseBook.Close True
    она сохраняется, вот только при последующем ее открытии, обычном, все рабочие листы скрыты хотя свойство IsAddin = False.
    Отобразить листы получилось только двойным изменением этого свойства на IsAddin = True и затем опять IsAddin = False.
    Поскажите, пожалуйста, как с этим можно "побороться"?
    Спасибо.

    • Перед objCloseBook.Close True попробуйте поставить строку:
      objCloseBook.Windows(1).Visible = true

      Однако в принципе Вам тогда можно также применять третий код сверху - почти тоже самое получится.

  9. VictorM:

    Сработало, спасибо.
    А третий код сверху я тоже пробовал.
    Разница у них в том, что при открытии книги таким способом виден ее ярлык в панели задач, а при помощи GetObject даже ярлыка не видно.
    Чем он мне и понравился.

  10. VictorM:

    Кстати, при применении предложенной Вами строки, все работает как нужно, но ярлык закрытой книги тоже стал появляться (на мгновение, правда) именно в момент objCloseBook.Windows(1).Visible = true

    • Да. Происходит все это потому, что GetObject открывает книгу в режиме скрытого окна - поэтому оно и не отображается на панели. А т.к. впоследствии Вы сохраняете книгу - то и состояние её окна сохраняется. И когда Вы потом её открываете - окно в скрытом режиме появляется и Вы, естественно, не видите ни одного листа. Режим IsAddin схож в данном плане, т.к. так же скрывает окно.
      Отобразить окно открытой потом книгу можно и без ухищрений: вкладка Вид-группа кнопок Окно-Отобразить. Выбрать нужную книгу.

Поделитесь своим мнением

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


Для оформления сообщений Вы можете использовать следующие тэги:
<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 Яндекс.Метрика
© 2019 Excel для всех   Войти