VBA, MS Access MS Access в примерах

MS Excel - Подключение листа книги

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

Public Function LinkExcelList(filePath As String, listName As String, tableName As String) As Long
' es 18.01.04
' Подлинковка листа книги Excel в режиме: READONLY - редакция данных не доступна
' Возвращает код ошибки или 0
'-------------------------------------------------------------------------
'Аргументы:
'   filePath   = Полный путь к файлу
'   listName   = Название листа
'   tableName  = Название таблицы (в текущей базе)
'-------------------------------------------------------------------------
Dim strLink As String
Dim tdf As TableDef
'Удаляем старую таблицу (если есть)
On Error Resume Next
    DoCmd.DeleteObject acTable, tableName
    Err.Clear
On Error GoTo LinkExcelListErr
'Задаем строку подключения
    strLink = "Excel 8.0;DATABASE=" & filePath
    Set tdf = CurrentDb.CreateTableDef(tableName)
    tdf.Connect = strLink
'Задаем название листа
    tdf.SourceTableName = listName & "$"
'Создание подлинкованной таблицы
    CurrentDb.TableDefs.Append tdf
    Set tdf = Nothing
    CurrentDb.TableDefs.Refresh
    DoEvents
    Exit Function

LinkExcelListErr:
    LinkExcelList = Err.Number
    MsgBox "Функция [LinkExcelList] привела к ошибке:" & vbCrLf & _
    Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical
End Function



Запросом:

Private Sub Test02()
Dim qdf As QueryDef
Dim StrSql As String
Dim sQueryName As String
Dim bQueryPresent As Boolean
Dim s$
    
'Путь у файлу
    's = GetFilePath(, "*.*sx", "Файл Excel", "*.xlsx")
    s = "d:\Temp\Пример\Пример.xlsx"
    
    If s = "" Then Exit Sub
    If Dir(s, vbNormal) = "" Then Exit Sub
    
'
    sQueryName = "qExcelList" 'Имя запроса
'Тело запроса
    StrSql = "SELECT * FROM [Лист1$] IN '" & s & "' [excel 12.0; hdr=yes]"
    
    ' Пытаемся узнать есть ли запрос с таким названием:
    For Each qdf In CurrentDb.QueryDefs
        'если запрос есть
        If qdf.Name = sQueryName Then
            bQueryPresent = True 'Запрос уже есть
        End If
    Next qdf
    
    If bQueryPresent = False Then
    ' создаем QueryDef
        Set qdf = CurrentDb.CreateQueryDef(sQueryName)
    Else
        'Если запрос уже открыт
        If CurrentData.AllQueries(sQueryName).IsLoaded Then
            DoCmd.Close acQuery, "sQueryName"
        End If
        Set qdf = CurrentDb.QueryDefs(sQueryName)
    
    End If
    
    qdf.sql = StrSql 'Задаём "тело" запроса
 
    ' открываем
    DoCmd.OpenQuery sQueryName, acViewNormal
    
    Set qdf = Nothing

End Sub

Заголовки столбцов должны быть проставлены!
(Подключает в режиме: READONLY - редакция данных не доступна.)

Назад ToTop
L.E. 06.03.2019
Рейтинг@Mail.ru