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

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

'

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

Function Fn_UnloadDataConnect(ByVal sFile As String, _

ByVal sShName 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 sCon As String ', sFile As String, sShName As String

Dim i, c, r

Dim rs As New ADODB.Recordset

Dim cn As New ADODB.connection

Dim m As Variant

'sFile = "<path_to_folder_or_file>.xls"

'sFile = "<path_to_folder_or_file>.xlsx"

'sShName = "SuiviAr"

'sShName = "Prod_TCM"

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

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

t = Timer

With cn

Select Case sExt

Case "xls"

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

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

Case "xlsx"

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

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

End Select

.Open

End With

sCon = "select * from [" & sShName & "$]"

rs.Open sCon, cn, 3, 3

Fn_UnloadDataConnect = rs.GetRows ': Stop

' Debug.Print UBound(aAr) & " - " & UBound(aAr, 2): Erase aAr

cn.Close

' rs.Close

Set rs = Nothing

Set cn = Nothing

Debug.Print Timer - t

End Function

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

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

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

'

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

Function Fn_UnloadDataConnect(ByVal sFile As String, _

ByVal sShName 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 sCon As String ', sFile As String, sShName As String

Dim i, c, r

Dim rs As New ADODB.Recordset

Dim cn As New ADODB.Connection

Dim m As Variant

'sFile = "<path_to_folder_or_file>.xls"

'sFile = "<path_to_folder_or_file>.xlsx"

'sShName = "SuiviAr"

'sShName = "Prod_TCM"

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

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

t = Timer

With cn

Select Case sExt

Case "xls"

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

.ConnectionString = "Data Source=" & sFile & ";" & "Extended Properties=Excel 8.0;"

Case "xlsx"

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

.ConnectionString = "Data Source=" & sFile & ";" & "Extended Properties=Excel 12.0;"

End Select

.Open

End With

sCon = "select * from [" & sShName & "$]"

rs.Open sCon, cn, 3, 3

Fn_UnloadDataConnect = rs.GetRows ': Stop

' Debug.Print UBound(aAr) & " - " & UBound(aAr, 2): Erase aAr

cn.Close

' rs.Close

Set rs = Nothing

Set cn = Nothing

Debug.Print Timer - t

End Function

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

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

'##### массив из листа EXCEL через ADO

Sub test_Fn_ArrInConnectADO()

strDataFullName = "<path_to_folder_or_file>.xlsx"

strSQL = "SELECT Expend.* FROM Expend;"

' Arr = Fn_ArrInConnectADO(strDataFullName, strSQL)

Arr = RecordSetFromSheet(strDataFullName, strSQL)

End Sub

Public Function RecordSetFromSheet(ByVal strDataFullName As String, _

ByVal strSQL As String) As Variant

sheetName = "Expend"

Dim rst As New ADODB.Recordset

Dim cnx As New ADODB.Connection

Dim cmd As New ADODB.Command

'setup the connection

'[HDR=Yes] means the Field names are in the first row

With cnx

' .Provider = "Microsoft.ACE.OLEDB.16.0"

' .ConnectionString = "Data Source='" & strDataFullName & "'; " & "Extended Properties='Excel 16.0;HDR=Yes;IMEX=1'"

.Provider = "Microsoft.ACE.OLEDB.16.0"

.ConnectionString = "Data Source=" & strDataFullName & ";" & "Extended Properties=Excel 16.0;"

.Open

End With

'setup the command

Set cmd.ActiveConnection = cnx

cmd.CommandType = adCmdText

cmd.CommandText = "SELECT * FROM [" & sheetName & "$]"

rst.CursorLocation = adUseClient

rst.CursorType = adOpenDynamic

rst.LockType = adLockOptimistic

'open the connection

rst.Open cmd

'disconnect the recordset

Set rst.ActiveConnection = Nothing

'cleanup

If CBool(cmd.State And adStateOpen) = True Then

Set cmd = Nothing

End If

If CBool(cnx.State And adStateOpen) = True Then cnx.Close

Set cnx = Nothing

'"return" the recordset object

Set RecordSetFromSheet = rst

End Function

'Public Sub Test()

'

'Dim rstData As ADODB.Recordset

'Set rstData = RecordSetFromSheet("ListRef")

'

'Sheets("ListPJI").Range("A1").CopyFromRecordset rstData

'

'End Sub

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

Function Fn_ArrInConnectADO(ByVal strDataFullName As String, _

ByVal strSQL As String) As Variant

Dim strAppVersion As String

Dim connDB As New ADODB.Connection

Dim rst As New ADODB.Recordset

'On Error Resume Next

strAppVersion = Application.Version

Select Case strAppVersion

Case "12.0"

strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _

strDataFullName & _

";Extended Properties=Excel 8.0;HDR=YES;"

Case "15.0"

strConnect = "Provider=Microsoft.ACE.OLEDB.15.0;Data Source=" & _

strDataFullName & _

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

Case "16.0"

strConnect = "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & _

strDataFullName & _

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

Case Else

End Select

Set connDB = CreateObject("ADODB.Connection")

connDB.Open ConnectionString:=strConnect

rst.Open strSQL, connDB

If Not rst.EOF Then

' Заполняем массив данными из рекордсета:

Fn_ArrInConnectADO = rst.GetRows

'Dim h As Long, v As Long

'h = UBound(Fn_ArrInConnectADO, 1) ' Определяем сколько колонок*

'v = UBound(Fn_ArrInConnectADO, 2) ' Определяем сколько строк*

Else

' Если нет данных то вывод сообщения:

MsgBox "Нет данных в таблице", vbInformation + vbOKOnly, "Ошибка"

End If

rst.Close

connDB.Close

' Вставим наш массив на Лист1

' Worksheets("Лист1").Range(Cells(1, 1), Cells(v + 1, h + 1)) = Application.Transpose(arr)

End Function

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