'===================================================================================================

'##### Загрузка данных напрямую из листа Excel в базу данных

Private Sub test_funUnloadDataConnect()

strFileEx = "f.xlsx"

strShName = "List_Def"

strFileDb = ThisWorkbook.Path & "\" & "TempDB.accdb"

Call funUnloadDataConnect(True, strFileEx, strShName, strFileDb)

End Sub

'---------------------------------------------------------------------------------------------------

Function funUnloadDataConnect(ByVal ReCreateTbl As Boolean, _

ByVal strFileEx As String, _

ByVal strShName As String, _

ByVal strFileDb As String)

Dim strSQL As String ', sFile As String, sShName As String

Dim rs As New ADODB.Recordset

Dim con As New ADODB.Connection

Dim m As Variant

m = Split(strFileEx, ".", -1, vbTextCompare)

sExt = m(UBound(m)): Erase m

With con

Select Case sExt

Case "xls"

.Provider = "Microsoft.Jet.OLEDB.4.0"

.connectionString = "Data Source=" & strFileDb '& ";" & "Extended Properties=Excel 8.0;"

Case "xlsx"

.Provider = "Microsoft.ACE.OLEDB.12.0"

.connectionString = "Data Source=" & strFileDb '& ";" & "Extended Properties=Excel 12.0;"

End Select

.Open

End With

Select Case ReCreateTbl

Case True: 'удалить таблицу

Set db = OpenDatabase(strFileDb)

If FnObjExists(db, "Table", strShName) Then db.Execute ("DROP TABLE [" & strShName & "]") '"Table", "Query",

db.Close

Set db = Nothing

strSQL = "SELECT * INTO " & strShName & _

" FROM [Excel 12.0 Xml;HDR=YES;DATABASE=" & strFileEx & "].[" & strShName & "$]"

Case False: strSQL = "INSERT INTO " & strShName & _

" SELECT * FROM [Excel 12.0 Xml;HDR=YES;IMEX=1;DATABASE=" & strFileEx & "].[" & strShName & "$]"

End Select

Debug.Print strSQL

Set rs = con.Execute(strSQL)

con.Close

Set rs = Nothing

Set cn = Nothing

End Function

'===================================================================================================

'===================================================================================================

'##### массив через рекордсет из указанного файла EXCEL

Private Sub test_funDownloadsDataConnect()

a = funDownloadsDataConnect("путь к фйлу.xlsx", "List_Def_Dept")

End Sub

'---------------------------------------------------------------------------------------------------

Function funDownloadsDataConnect(ByVal strFileEx As String, _

ByVal strShName As String) As Variant

''-----------------------------------

''Для Excel 12.0

'connectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" + FileName + _

"; Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

''Для более ранних версий

'connectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + FileName + _

"; Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''-----------------------------------

Dim strSQL As String ', sFile As String, sShName As String

Dim i, c, r

Dim rs As New ADODB.Recordset

Dim con As New ADODB.Connection

Dim m As Variant

m = Split(strFileEx, ".", -1, vbTextCompare)

sExt = m(UBound(m)): Erase m

With con

Select Case sExt

Case "xls"

.Provider = "Microsoft.Jet.OLEDB.4.0"

.connectionString = "Data Source=" & strFileEx & ";" & "Extended Properties=Excel 8.0;"

Case "xlsx"

.Provider = "Microsoft.ACE.OLEDB.12.0"

.connectionString = "Data Source=" & strFileEx & ";" & "Extended Properties=Excel 12.0;"

End Select

.Open

End With

strSQL = "select * from [" & strShName & "$]"

rs.Open strSQL, con, 3, 3

funDownloadsDataConnect = rs.GetRows ': Stop

con.Close

Set rs = Nothing

Set cn = Nothing

End Function

'===================================================================================================