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

MS Excel - Подключение листа книги (tdf.Connect)

Запросом:
...
Есть книга Excel "C:\Data\Новые сотрудники.xls". В этой книге есть лист "output", с таблицей данных (первая строка - название полей).

SELECT * INTO Temp FROM [output$] IN 'C:\Data\Новые сотрудники.xls'[excel 8.0; hdr=yes;]

Или:


SELECT *
FROM (SELECT * FROM [sheet1$A:D] AS xlData IN 'C:\path to file\myExcelFileName.xlsx'[Excel 12.0;HDR=yes;IMEX=1;ACCDB=Yes]) AS XL

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

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 GoTo LinkExcelListErr
'Задаем строку подключения
    strLink = "Excel 8.0;DATABASE=" & filePath
    Set tdf = CurrentDb.CreateTableDef(tableName)
    tdf.Connect = strLink
'Задаем название листа
    tdf.SourceTableName = listName & "$"
'Удаление старой (если есть)
    If DCount("*", "MSysObjects", "[Name]='" & tableName & "' AND Type=6") > 0 Then
        CurrentDb.TableDefs.Delete tableName
    End If

'Создание подлинкованной таблицы
    CurrentDb.TableDefs.Append tdf
    Set tdf = Nothing

'Обновление Области Навигации (Navigation Pane)
    CurrentDb.TableDefs.Refresh
    Application.RefreshDatabaseWindow
    DoEvents
    Exit Function

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


Пример эксплуатации:

Dim lVal As Long, s$
'Подлинковка листа книги Excel в режиме: READONLY
'   Путь:              "d:\Downloads\DocsSetExcel.xlsx"
'   Название листа:    "List01"
'   Название таблицы:  "0LinkedExcelList"
    lVal = LinkExcelList("d:\Downloads\DocsSetExcel.xlsx", "List01", "0LinkedExcelList")

    If lVal > 0 Then Exit Sub 'проверка как всё прошло
    
'Тут импортируем данные ...
    's = "INSERT INTO ... SELECT ... FROM 0LinkedExcelList ..."
    'CurrentDb.Execute s
    
'Готово! - Простое удаление таблицы листа книги Excel
   DoCmd.DeleteObject acTable, "0LinkedExcelList"



Запросом:

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. 20.07.2023
Рейтинг@Mail.ru