Private Sub BazaDan()
Dim cn As ADODB.Connection
Dim cmd As ADODB.Command
Dim DBFullName As String


'// блок оптимизация работы excel
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
'\\


'// открываем книгу, если книга не та, то возобновляется процедура открытия книги
Dim proverka As Boolean
proverka = True
zanovo: 'возвращаемся сюда, если выбрали не тот файл
proverka = True
Dim OpenBook As Workbook

FileToOpen = Application.GetOpenFilename(Title:="Открыть файл", FileFilter:="Excel Files *.xls* (*.xls*),") 'диалог открытия книги
If FileToOpen = False Then
    MsgBox "Файл не выбран", vbExclamation, "Информация"
    Exit Sub
    Else
        Workbooks.Open Filename:=FileToOpen
        Set OpenBook = ActiveWorkbook
        OpenBook.Activate
End If
'\\


'// заносим необходимые данные из открытой книги в массив
Application.DisplayAlerts = False ' отключаем лишние запросы типа сохранить или нет :)
Dim sh As Worksheet
Dim rng As Range
Dim y As Integer
Dim names(1 To 300) As String
Dim stepen(1 To 300) As Integer
Dim material(1 To 300) As Currency
Dim tzr(1 To 300) As Currency
Dim zp(1 To 300) As Currency
Dim dopzp(1 To 300) As Currency
Dim strah(1 To 300) As Currency
Dim ceh(1 To 300) As Currency
Dim ceh_s(1 To 300) As Currency
Dim zavod(1 To 300) As Currency
Dim zavod_s(1 To 300) As Currency
Dim prib(1 To 300) As Currency
Dim itog(1 To 300) As Currency
y = 0
For Each asd In OpenBook.Worksheets 'вводим цикл для каждого листа в открытой книге
    If y = 0 Then GoTo propusk
    Set sh = OpenBook.Worksheets(y + 1)
    names(y) = sh.Range("a2")
    stepen(y) = CInt(Val(Right((sh.Range("c3")), 1)))
    material(y) = sh.Range("f5")
    tzr(y) = sh.Range("f6")
    zp(y) = sh.Range("f7")
    dopzp(y) = sh.Range("f8")
    strah(y) = sh.Range("f9")
    ceh(y) = sh.Range("f10")
    ceh_s(y) = sh.Range("f11")
    zavod(y) = sh.Range("f12")
    zavod_s(y) = sh.Range("f13")
    prib(y) = sh.Range("f14")
    itog(y) = sh.Range("f15")
propusk:
    y = y + 1
Next
'\\


'// работа с базой данных
DBFullName = "C:\входящие\управляющие файлы\DOS_PEO.accdb"
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFullName & ""
cn.Open
Dim x As Integer
For x = 1 To y - 1
    Set cmd = New ADODB.Command
    With cmd
        .ActiveConnection = cn
        .CommandText = "INSERT INTO DATA (names, stepen, material, tzr, zp, dopzp, strah, ceh,ceh_s,zavod,zavod_s,prib,itog) VALUES (" & names(x) & "," & stepen(x) & "," & material(x) & "," & tzr(x) & "," & zp(x) & "," & dopzp(x) & "," & strah(x) & "," & ceh(x) & "," & _
        ceh_s(x) & "," & zavod(x) & "," & zavod_s(x) & "," & prib(x) & "," & itog(x) & ");"
End With
    cmd.Execute
Next x
cn.Close
Set cn = Nothing
'\\ окончание работы с базой данных


End Sub