Option Compare Database
Option Explicit
Private Sub btnOK_Click()
Dim strMonth As String, strYear As String
Dim strFilePath As String
Dim xlApp As Object, xlBook As Object, xlRange As Object
Dim db As DAO.Database, rs As DAO.Recordset, rsSettings As DAO.Recordset
Dim fileDialog As Object
Dim tblName As String, rngName As String
Dim sqlCheck As String, sqlInsert As String
' Получаем выбранный месяц и год
strMonth = Me.cmbMonth.Value
strYear = Me.cmbYear.Value
If strMonth = "" Or strYear = "" Then
MsgBox "Выберите месяц и год!", vbExclamation
Exit Sub
End If
' Формируем путь: "год/месяц/месяц_год.xlsx"
strFilePath = "C:\Путь\к\файлам\" & strYear & "\" & strMonth & "\" & strMonth & "_" & strYear & ".xlsx"
' Открываем таблицу настроек и получаем параметры
Set db = CurrentDb
Set rsSettings = db.OpenRecordset("tblSettings", dbOpenDynaset)
If Not (rsSettings.EOF And rsSettings.BOF) Then
tblName = rsSettings!TableName
rngName = rsSettings!RangeName
Else
MsgBox "Не найдены настройки!", vbCritical
Exit Sub
End If
rsSettings.Close
Set rsSettings = Nothing
' Проверяем, существует ли файл
If Dir(strFilePath) = "" Then
MsgBox "Файл не найден. Выберите вручную.", vbExclamation
Set fileDialog = Application.FileDialog(3)
If fileDialog.Show = -1 Then
strFilePath = fileDialog.SelectedItems(1)
Else
Exit Sub
End If
End If
' Проверка наличия данных за выбранный месяц
sqlCheck = "SELECT COUNT(*) AS RecCount FROM " & tblName & " WHERE Format(Дата, 'YYYY-MM') = '" & strYear & "-" & Format(Month(DateValue("01 " & strMonth & " 2000")), "00") & "'"
Set rs = db.OpenRecordset(sqlCheck)
If rs!RecCount > 0 Then
If MsgBox("Данные за " & strMonth & " " & strYear & " уже существуют. Добавить еще?", vbYesNo + vbQuestion) = vbNo Then
rs.Close
Set rs = Nothing
Exit Sub
End If
End If
rs.Close
Set rs = Nothing
' Открываем Excel
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
If xlApp Is Nothing Then
MsgBox "Ошибка при запуске Excel.", vbCritical
Exit Sub
End If
' Открываем файл
Set xlBook = xlApp.Workbooks.Open(strFilePath)
On Error Resume Next
Set xlRange = xlBook.Names(rngName).RefersToRange
On Error GoTo 0
If xlRange Is Nothing Then
MsgBox "Диапазон '" & rngName & "' не найден в файле!", vbCritical
xlBook.Close False
xlApp.Quit
Exit Sub
End If
' Добавляем данные в таблицу Access
Dim i As Integer, rowValues As String
For i = 1 To xlRange.Rows.Count
rowValues = ""
Dim j As Integer
For j = 1 To xlRange.Columns.Count
rowValues = rowValues & "'" & xlRange.Cells(i, j).Value & "',"
Next j
rowValues = Left(rowValues, Len(rowValues) - 1)
sqlInsert = "INSERT INTO " & tblName & " VALUES (" & rowValues & ")"
db.Execute sqlInsert, dbFailOnError
Next i
' Закрываем всё
xlBook.Close False
xlApp.Quit
' Освобождаем память
Set xlRange = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Set db = Nothing
MsgBox "Импорт завершён!", vbInformation
End Sub