MyTetra Share
Делитесь знаниями!
Как получить данные из закрытой книги?
Время создания: 16.03.2019 23:43
Раздел: Разные закладки - VBA - GetOpen
Запись: xintrea/mytetra_db_adgaver_new/master/base/1514993912cvosl4z3pv/text.html на raw.githubusercontent.com

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

Достаточно часто появляется вопрос: как извлечь данные из закрытой книги 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


1

2

3

4

5

6

7

8

9

10

11

12

13

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


1

2

3

4

5

6

7

8

9

10

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 'Включаем обновление экрана Application.ScreenUpdating = True End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

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

    'Включаем обновление экрана

    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 'Включаем обновление экрана Application.ScreenUpdating = True End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

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

    'Включаем обновление экрана

    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


1

2

3

4

5

6

7

8

9

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


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

'---------------------------------------------------------------------------------------

' 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


1

2

3

4

5

6

7

'---------------------------------------------------------------------------------------

' 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


1

Cells(1, 1).CopyFromRecordset objRS


на такую:

Extract_Value_ADO = objRS.Fields(0).Value


1

Extract_Value_ADO = objRS.Fields(0).Value


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

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



1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

'---------------------------------------------------------------------------------------

' 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 - заголовок
Хоть эта функция имеет определенные недостатки - она может быть в разы быстрее предыдущей.

Так же в этом разделе:
 
MyTetra Share v.0.65
Яндекс индекс цитирования