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(sExcelFilePath As String, sListName As String, sLocTableName As String) As Long
' Подлинковка листа книги Excel в режиме: READONLY - редакция данных не доступна
' Внимание!!! - Первая строка листа должна содержать имена столбцов!
' Возвращает код ошибки или 0
'-------------------------------------------------------------------------
'Аргументы:
'   sExcelFilePath = Полный путь к файлу
'   sListName      = Название листа
'   sLocTableName  = Название таблицы листа в текущей базе
'-------------------------------------------------------------------------
Dim strLink As String
Dim tdf As TableDef
On Error GoTo LinkExcelListErr
'Создание строки подключения:
    strLink = "Excel 12.0;DATABASE=" & sExcelFilePath
    Set tdf = CurrentDb.CreateTableDef(sLocTableName)
    tdf.Connect = strLink
    tdf.SourceTableName = sListName & "$" 'Название листа
'Удаление старой таблицы (если есть):
    If DCount("*", "MSysObjects", "[Name]='" & sLocTableName & "' AND Type=6") > 0 Then
        CurrentDb.TableDefs.Delete sLocTableName
    End If
    CurrentDb.TableDefs.Append tdf    'Создание подлинкованной таблицы
    Application.RefreshDatabaseWindow 'Обновление Области Навигации (Navigation Pane)

LinkExcelListEnd:
    Set tdf = Nothing
    Exit Function

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


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

Private Sub Demo_LinkExcelList()
Dim lVal As Long, sPath$, sVal$
'Подлинковка листа книги Excel в режиме: READONLY
'   Путь:
    sPath = "d:\Temp\Del\Asnya911 Файл для тестов 050.xlsx"
'   Название листа:    "Продажи"
'   Название таблицы:  "LinkedExcelList"
    lVal = LinkExcelList(sPath, "Продажи", "LinkedExcelList") 'Подключение
    If lVal > 0 Then 'проверка как всё прошло
        'MsgBox "Произошла ошибка при подключении!", vbCritical
        Exit Sub 
    End If
'Тут импортируем данные ...
    'sVal = "INSERT INTO ... SELECT ... FROM LinkedExcelList ..."
    'CurrentDb.Execute sVal
'Готово! - Простое удаление таблицы листа книги Excel после импорта
   'DoCmd.DeleteObject acTable, "LinkedExcelList"
End Sub



Запросом:

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