Sub Recordset2Range()
Dim cnn As Connection
Dim rst As Recordset
Dim sSQL As String
Dim rCount&
Set cnn = GetConnXLS(ThisWorkbook.FullName)
On Error GoTo lbEndSub
sSQL = "SELECT * FROM KHO WHERE Ngay =#" & Range("C2").Value & "# "
Set rst = New Recordset
rst.Open sSQL, cnn
Range("A4:T65536").ClearContents
rCount = Range("A4").CopyFromRecordset(rst)
lbEndSub:
If rst.State = adStateOpen Then
rst.Close
End If
Set rst = Nothing
If cnn.State = adStateOpen Then
cnn.Close
End If
Set cnn = Nothing
If Err.Number <> 0 Then
MsgBox Err.Number & " - " & Err.Description, vbCritical
End If
End Sub
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False) As ADODB.Connection
On Error GoTo LOI:
'Open the ADO connection to the Excel workbook
Dim oConn As ADODB.Connection
Dim Ext As String, ConnStr As String
Set oConn = New ADODB.Connection
Ext = GetFileExt(cFileName)
If Len(Ext) = 3 And Left(Ext, 2) = "xl" Then
ConnStr = "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
cFileName & _
";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
Else
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
cFileName & _
";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";" 'Co the bo ;IMEX=1
End If
'Cach 1
'oConn.Open "Provider=MSDASQL.1;Persist Security Info=true;" & _
"Extended Properties=""DSN=Excel Files;DBQ=" & cFileName & ";DefaultDir=" & _
GetPathFile(cFileName) & _
";DriverId=790;FIL=excel 8.0;HDR=YES;MaxBufferSize=2048;PageTimeout=5;"""
'Cach 2: Khong dung duoc so sanh LIKE, SUM(IIF(...)
'oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;"""
'Cach 3 khong can qua DSN
'ConnStr = "ODBC;DBQ=" & cFileName & ";DefaultDir=" & GetPathFile(cFileName) & ";Driver={Microsoft Excel Driver (*.xls)};DriverId=790;FIL=excel 8.0;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;ReadOnly=0;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
oConn.Open ConnStr
Set GetConnXLS = oConn
LOI:
If Err.Number <> 0 Then
Set oConn = Nothing
If InformErrMSG Then
MsgBox "GetConnXLS" & ": " & Err.Number & " - " & Err.Description, vbCritical
End If
End If
End Function
Function GetFileExt(ByVal cFile As String) As String
'<EhHeader>
On Error GoTo GetNameFile_Err
'</EhHeader>
Dim p As Integer
p = InStrRev(cFile, ".")
If p > 0 Then
GetFileExt = Mid(cFile, p + 1, Len(cFile) - p)
End If
'<EhFooter>
Exit Function
GetNameFile_Err:
MsgBox Err.Description & vbCrLf & _
"in GetFileExt" & _
"at line " & Erl, _
vbExclamation + vbOKOnly, "Application Error"
'</EhFooter>
End Function
