Автоматизировать импорт данных в Access из Excel

'--------------------------------------------------------------------------
' Module    : modImportTabelFromExcel
' Author    : es
' Date      : 12.07.2018
' Purpose   : Импорт справочника "Tabel"
'--------------------------------------------------------------------------
Option Compare Database
Option Explicit
'Private Sub test0001()
'    ImportTabelFromExcel
'End Sub
 
Public Sub ImportTabelFromExcel()
'es - 30.08.2019
'
'--------------------------------------------------------------------------
Dim sFilePath$ 'Ну понятно путь (в аргументе)
Dim sWorksheetName As String
Dim v As Variant, l&, i%, s$
Dim lTotUPD&, lTotAdded&
 
On Error GoTo ImportTabelFromExcel_Err
  
    s = INIRead("Last Import Folder", CurrentProject.Path, "Import from Excel")
    sFilePath = OpenFileDialog(s, , "MS Excel WorkBooks", "*.xls; *.xlsx")
    
    If sFilePath = "" Then
        'Debug.Print "No File!"
        GoTo ImportTabelFromExcel_End
    End If
    
    'Debug.Print "File FromExcel: " & sFilePath
    s = FolderByPath(sFilePath)
 
'Запись
    INIWrite "Last Import Folder", s, "Import from Excel"
    DoCmd.Hourglass True 'Показать часики
  
'Проверка данных в книге
    s = "DateReport, Affilate, TabNum, FIO, HirDate, DisDate, SR_Name_Rus, Pr_Name_Rus, MainArea_VC, PersCatName, " & _
        "GrafikCode, Klg_Collar, Holiday_Beg, Holiday_End, Illness_Beg, Illness_End, DecretN, UhodN"
   
   
    sWorksheetName = CheckFieldsInExcelWB(sFilePath, s, 64) 'вообще = 57 полей
'GoTo ImportTabelFromExcel_End
 
    If sWorksheetName = "" Then
        MsgBox "В файле:" & vbCrLf & sFilePath & vbCrLf & _
        "Не обнаружено данных для импорта." & vbCrLf & _
        "Пожалуйста укажите другой файл.", vbExclamation, "Ошибка данных"
        GoTo ImportTabelFromExcel_End
    End If
 
'Debug.Print "Найден лист: " & sWorksheetName & " i=" & i
'--------------------------------------------------------------------------
    
    
    l = LinkExcelList(sFilePath, sWorksheetName, "TabelExcelImport")
    If l > 0 Then GoTo ImportTabelFromExcel_End
 
'Зачистка
    s = "DELETE FROM tp_TabelFromExcel" 'на усякий случай чистим от прошлых данных !
    CurrentDb.Execute s
 
'md_ImportTabelFromExcel_01 - Заполнение времянки
    s = "md_ImportTabelFromExcel_01"
    CurrentDb.Execute s '
 
'Обновление всех полей у существующих
    s = "md_ImportTabelFromExcel_02"
    CurrentDb.Execute s
    
    lTotUPD = DCount("*", "tp_TabelFromExcel", "impUpdated = True") 'считаем сколько обновлено
 
'Добавление новых
    s = "md_ImportTabelFromExcel_03"
    CurrentDb.Execute s
 
    
    lTotAdded = DCount("*", "tp_TabelFromExcel", "impUpdated = False") 'считаем сколько Добавлено
 
'Отсутствующие НЕ УДАЛЯЕМ!!!
'GoTo ImportTabelFromExcel_End ' END
 
 
'END! ...
    MsgBox "Импорт из файла:" & vbCrLf & _
        sFilePath & vbCrLf & _
        "Произведён." & vbCrLf & _
        "Обновлено: " & lTotUPD & " записей." & vbCrLf & _
        "Добавлено: " & lTotAdded & " записей.", vbInformation, "OK!"
 
 
 
ImportTabelFromExcel_End:
    On Error Resume Next
    
    DoCmd.Hourglass False 'Вернуть нормальный курсор
    
    CurrentDb.TableDefs.Delete "TabelExcelImport"
    CurrentDb.TableDefs.Refresh
 
    Err.Clear
    Exit Sub
 
ImportTabelFromExcel_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Sub: ImportTabelFromExcel in module: modImportTabelFromExcel", vbCritical, "Error in Application"
    Err.Clear
      Debug.Print "Line: " & Erl & "."
    Resume ImportTabelFromExcel_End
End Sub
 
 
Private Function CheckFieldsInExcelWB(sFilePath$, sFieldsList$, Optional iFieldsEndCol% = 100) As String
'es - 30.08.2019
'Проверка полей в книге (перед импортом например) в произвольном порядке
'Возвращает название первого листа прошедшего проверку
'----------------------------------------------------------------
'Аргументы:
'   sFilePath$     'Ну понятно = путь к книге
'   sFieldsList    'Список названий полей через запятую
'   iFieldsEndCol  'Номер столбца = Конец заголовка полей (по умолч =100)
'----------------------------------------------------------------
Dim objExcelApp As Object
Dim objWorkBook As Object
Dim objWorkSheet As Object
Dim s$, iVal%, iValSub%, xVal%, vVal As Variant
Dim iTotalFields%, iFoundFields%
Dim arrFielsCheck() As String 'Массив полей которые проверяем
Dim arrFielsIn() As String    'Массив полей где проверяем
 
On Error GoTo CheckFieldsInExcelWB_Err
    
    s = Replace(sFieldsList, " ", "") 'Убираем пробелы!
    arrFielsCheck = Split(s, ",")     'Загоняем список в массив
    
    iTotalFields = UBound(arrFielsCheck)
    If iTotalFields = 0 Then
        MsgBox "Проверяемые поля не обнаружены!", vbCritical
        GoTo CheckFieldsInExcelWB_End
    End If
    
    iTotalFields = iTotalFields + 1
'Debug.Print "Проверяемых полей: " & iTotalFields
    
    For iVal = LBound(arrFielsCheck) To xVal
        arrFielsCheck(iVal) = Trim(arrFielsCheck(iVal)) 'На всякий случай ...
        'Debug.Print Format(iVal + 1, "000"); ". " & arrFielsCheck(i) '& "."
    Next iVal
 
    Set objExcelApp = CreateObject("Excel.Application")
    Set objWorkBook = objExcelApp.Workbooks.Open(sFilePath)
 
    
'Перебор всех листов книги
    s = ""
    For Each objWorkSheet In objWorkBook.WorkSheets
        'Debug.Print "Название листа: " & objWorkSheet.Name
        With objWorkSheet
            For iVal = 1 To iFieldsEndCol
                vVal = .Cells(1, iVal).Value
                'Debug.Print Format(i, "000") & " = " & vVal
                If vVal <> "" Then s = s & vVal & ";"
            Next iVal
        End With
        
        arrFielsIn = Split(s, ";") 'Загоняем список в массив
 
        For iVal = LBound(arrFielsCheck) To UBound(arrFielsCheck)
            'Поиск среди обнаруженных в листе полей:
            For iValSub = LBound(arrFielsIn) To UBound(arrFielsIn)
                s = arrFielsIn(iValSub)
                If arrFielsCheck(iVal) = s Then 'поле найдено!
                    iFoundFields = iFoundFields + 1
                    'Debug.Print Format(iValSub + 1, "000"); " = " & arrFielsIn(iValSub)
                    Exit For
                End If
            Next iValSub
        Next iVal
        
        If iFoundFields = iTotalFields Then 'всё найдено
            CheckFieldsInExcelWB = objWorkSheet.Name
            Exit For
        End If
 
    Next objWorkSheet
  
'Debug.Print "Найдено полей: " & iFoundFields
'Debug.Print "Найден лист: " & CheckFieldsInExcelWB & " iVal=" & iVal
 
CheckFieldsInExcelWB_End:
    On Error Resume Next
    
    objWorkBook.Close
    Set objWorkBook = Nothing
    objExcelApp.Quit
    Set objExcelApp = Nothing
    
    Err.Clear
    Exit Function
 
CheckFieldsInExcelWB_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function CheckFieldsInExcelWB.", _
        vbCritical, "Произошла ошибка!"
    Debug.Print "Line: " & Erl & "."
    Err.Clear
    Resume CheckFieldsInExcelWB_End
 
End Function
 
Private 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
    'или так:
    strLink = "Excel 12.0 Xml;HDR=YES;IMEX=2;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